addfile ./darcs2camp.hs hunk ./darcs2camp.hs 1 + +-- Copyright 2008 Ian Lynagh. +-- Uses the darcs source, so GPL. + +import qualified Camp.Diff +import qualified Camp.Patch.Apply +import qualified Camp.Patch.Primitive +import qualified Camp.Patch.Sequence + +import Darcs.Flags +import Darcs.Hopefully +import Darcs.Ordered +import Darcs.Patch +import Darcs.Patch.Core +import Darcs.Patch.FileName +import Darcs.Patch.Prim +import Darcs.Patch.Set +import Darcs.Repository.DarcsRepo +import Darcs.Sealed +import FastPackedString + +import Control.Exception +import Control.Monad.State +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSC +import Data.List +import System.Directory +import System.Environment +import System.FilePath +import System.IO +import Unsafe.Coerce + +flags :: [DarcsFlag] +flags = [] + +main :: IO () +main = do hSetBuffering stdout NoBuffering + [repo] <- getArgs + createDirectory "darcs" + createDirectory "camp" + ps1 <- read_repo flags repo + let MkCounts primpatches patches + = unseal (countPatchSet (MkCounts 0 0)) ps1 + evaluate primpatches + evaluate patches + ps2 <- read_repo flags repo + unseal (flip evalStateT (primpatches, patches, 0, 0) . handlePatchSet 1) + ps2 + checkConsistent "darcs" "camp" + putStrLn "" + putStrLn "Done!" + +----- + +data MkCounts = MkCounts !Int !Int + +countPatchSet :: MkCounts -> PatchSet Patch -> MkCounts +countPatchSet counts NilRL = counts +countPatchSet counts (x :<: xs) = countPatchSet (countRL counts x) xs + +countRL :: MkCounts -> RL (PatchInfoAnd Patch) -> MkCounts +countRL counts NilRL = counts +countRL (MkCounts npp np) (p :<: ps) + = case hopefully p of + NamedP _ _ patch -> countRL (countPatch (MkCounts npp (np + 1)) patch) ps + +countPatch :: MkCounts -> Patch -> MkCounts +countPatch (MkCounts npp np) (PP _) = MkCounts (npp + 1) np +countPatch (MkCounts npp np) (ComP ps) = MkCounts (npp + lengthFL ps) np +countPatch counts (Merger eff _ _ _) = countPatch counts eff +countPatch counts (Regrem effi _ _ _) = countPatch counts effi + +----- + +type Counts = (Int, -- total primpatches + Int, -- total patches + Int, -- prim patches so far + Int) -- patches so far + +type M = StateT Counts IO + +handlePatchSet :: Int -> PatchSet Patch -> M Int +handlePatchSet i NilRL = return i +handlePatchSet i (x :<: xs) = do i' <- handlePatchSet i xs + handleRL i' x + +handleRL :: Int -> RL (PatchInfoAnd Patch) -> M Int +handleRL i NilRL = return i +handleRL i (p :<: ps) + = do i' <- handleRL i ps + case hopefully p of + NamedP pi _ patch -> + do nextPatch + handlePatch patch + return (i' + 1) + +handlePatch :: Patch -> M () +handlePatch (PP prim) = do handlePrim prim + return () +handlePatch (ComP patches) = sequence_ $ mapFL handlePatch patches +handlePatch (Merger eff _ _ _) = handlePatch eff +handlePatch (Regrem effi _ _ _) = handlePatch (invert effi) + +inDarcs :: IO a -> IO a +inDarcs io = do d <- getCurrentDirectory + setCurrentDirectory "darcs" + r <- io + setCurrentDirectory d + return r + +inCamp :: IO a -> IO a +inCamp io = do d <- getCurrentDirectory + setCurrentDirectory "camp" + r <- io + setCurrentDirectory d + return r + +checkConsistent :: FilePath -> FilePath -> IO () +checkConsistent x y = do xs <- getDirectoryContents x + ys <- getDirectoryContents y + let xs' = filter (`notElem` [".", ".."]) $ sort xs + ys' = filter (`notElem` [".", ".."]) $ sort ys + unless (xs' == ys') $ + error ("Inconsistent: " ++ show x) + mapM_ f xs' + where f z = do isD <- doesDirectoryExist (x z) + if isD then checkConsistent (x z) (y z) + else filesSame (x z) (y z) + filesSame a b = do a' <- BS.readFile a + b' <- BS.readFile b + unless (a' == b') $ + error ("Inconsistent: " ++ show a) + +handlePrim :: Prim -> M (Camp.Patch.Sequence.Seq + Camp.Patch.Primitive.Primitive from to) +handlePrim p = do _pp <- nextPrimPatch + liftIO $ do inDarcs $ apply flags p + campPrims <- handlePrim' p + inCamp $ applyCamp campPrims + -- when (pp `mod` 1000 == 0) $ + -- checkConsistent "darcs" "camp" + return campPrims + +nextPrimPatch :: M Int +nextPrimPatch + = do (totalPrimPatches, totalPatches, primPatchesSoFar, patchesSoFar) <- get + let primPatchesSoFar' = primPatchesSoFar + 1 + liftIO $ putStr ("\r" ++ show patchesSoFar ++ "/" ++ show totalPatches + ++ " " ++ show primPatchesSoFar' ++ "/" + ++ show totalPrimPatches) + put (totalPrimPatches, totalPatches, primPatchesSoFar', patchesSoFar) + return primPatchesSoFar' + +nextPatch :: M () +nextPatch + = do (totalPrimPatches, totalPatches, primPatchesSoFar, patchesSoFar) <- get + let patchesSoFar' = patchesSoFar + 1 + liftIO $ putStr ("\r" ++ show patchesSoFar' ++ "/" ++ show totalPatches + ++ " " ++ show primPatchesSoFar ++ "/" + ++ show totalPrimPatches) + put (totalPrimPatches, totalPatches, primPatchesSoFar, patchesSoFar') + +applyCamp :: Camp.Patch.Sequence.Seq Camp.Patch.Primitive.Primitive from to + -> IO () +applyCamp Camp.Patch.Sequence.Nil = return () +applyCamp (Camp.Patch.Sequence.Cons p ps) = do Camp.Patch.Apply.apply p + applyCamp ps + +-- XXX Should check and normalise filepaths +handlePrim' :: forall from to . + Prim -> IO (Camp.Patch.Sequence.Seq + Camp.Patch.Primitive.Primitive from to) +handlePrim' (Move from to) + = do let from' = fn2fp from + to' = fn2fp to + isDir <- doesDirectoryExist ("camp" from') + if isDir + then return (singleton (Camp.Patch.Primitive.MvDir from' to')) + else return (singleton (Camp.Patch.Primitive.MvFile from' to')) +handlePrim' (DP fn RmDir) + = return (singleton (Camp.Patch.Primitive.RmDir (fn2fp fn))) +handlePrim' (DP fn AddDir) + = return (singleton (Camp.Patch.Primitive.AddDir (fn2fp fn))) +handlePrim' (FP fn RmFile) + = return (singleton (Camp.Patch.Primitive.RmFile (fn2fp fn))) +handlePrim' (FP fn AddFile) + = return (singleton (Camp.Patch.Primitive.AddFile (fn2fp fn))) +handlePrim' (FP fn (Hunk {})) + = do let fp = fn2fp fn + -- This can actually return multiple hunks, e.g. with + -- "" -> "a\n\nb\n" + -- the empty line in the original file can map to the + -- second line of the new file + inDarcs $ Camp.Diff.diffFile (".." "camp" fp) fp +handlePrim' (FP fn (TokReplace {})) + = do let fp = fn2fp fn + inDarcs $ Camp.Diff.diffFile (".." "camp" fp) fp +handlePrim' (FP fn (Binary old new)) + = return (singleton (Camp.Patch.Primitive.Binary (fn2fp fn) + (BSC.pack (unpackPS old)) + (BSC.pack (unpackPS new)) + )) +handlePrim' (Split {}) = error "XXX Split patches aren't handled" +handlePrim' (Identity {}) = error "XXX Identity patches aren't handled" +handlePrim' (ChangePref {}) = return (unsafeCoerce Camp.Patch.Sequence.Nil) + +singleton :: Camp.Patch.Primitive.Primitive from to -> + Camp.Patch.Sequence.Seq Camp.Patch.Primitive.Primitive from to +singleton p = Camp.Patch.Sequence.Cons p Camp.Patch.Sequence.Nil + hunk ./darcs2camp.hs 9 +import qualified Camp.Record +import qualified Camp.Repository hunk ./darcs2camp.hs 31 +import System.Exit hunk ./darcs2camp.hs 34 +import System.Process hunk ./darcs2camp.hs 45 + ec <- inCamp $ rawSystem "camp" ["init"] + case ec of + ExitSuccess -> return () + _ -> error "camp init failed" + putStrLn "Counting patches" hunk ./darcs2camp.hs 55 + putStrLn "Converting patches" hunk ./darcs2camp.hs 57 - unseal (flip evalStateT (primpatches, patches, 0, 0) . handlePatchSet 1) + unseal (flip evalStateT (primpatches, patches, 0, 0) . + handlePatchSet) hunk ./darcs2camp.hs 80 -countPatch (MkCounts npp np) (ComP ps) = MkCounts (npp + lengthFL ps) np +countPatch counts (ComP NilFL) = counts +countPatch counts (ComP (p :>: ps)) = countPatch (countPatch counts p) (ComP ps) hunk ./darcs2camp.hs 94 -handlePatchSet :: Int -> PatchSet Patch -> M Int -handlePatchSet i NilRL = return i -handlePatchSet i (x :<: xs) = do i' <- handlePatchSet i xs - handleRL i' x +handlePatchSet :: PatchSet Patch -> M () +handlePatchSet NilRL = return () +handlePatchSet (x :<: xs) = do handlePatchSet xs + handleRL x hunk ./darcs2camp.hs 99 -handleRL :: Int -> RL (PatchInfoAnd Patch) -> M Int -handleRL i NilRL = return i -handleRL i (p :<: ps) - = do i' <- handleRL i ps +handleRL :: RL (PatchInfoAnd Patch) -> M () +handleRL NilRL = return () +handleRL (p :<: ps) + = do handleRL ps hunk ./darcs2camp.hs 106 - handlePatch patch - return (i' + 1) + prims <- handlePatch patch + liftIO $ inCamp $ do + r <- Camp.Repository.getRepo + -- XXX Should make our own name really + n <- Camp.Repository.genName r + Camp.Record.recordMegaPatch r n prims hunk ./darcs2camp.hs 113 -handlePatch :: Patch -> M () -handlePatch (PP prim) = do handlePrim prim - return () -handlePatch (ComP patches) = sequence_ $ mapFL handlePatch patches +handlePatch :: Patch -> M (Camp.Patch.Sequence.Seq + Camp.Patch.Primitive.Primitive from to) +handlePatch (PP prim) = handlePrim prim +handlePatch (ComP NilFL) = return nil +handlePatch (ComP (p :>: ps)) + = do s1 <- handlePatch p + s2 <- handlePatch (ComP ps) + return (s1 `Camp.Patch.Sequence.appendSeq` s2) hunk ./darcs2camp.hs 124 -inDarcs :: IO a -> IO a -inDarcs io = do d <- getCurrentDirectory - setCurrentDirectory "darcs" - r <- io +inDir :: FilePath -> IO a -> IO a +inDir d io = do curDir <- getCurrentDirectory hunk ./darcs2camp.hs 127 + r <- io + setCurrentDirectory curDir hunk ./darcs2camp.hs 131 +inDarcs :: IO a -> IO a +inDarcs = inDir "darcs" + hunk ./darcs2camp.hs 135 -inCamp io = do d <- getCurrentDirectory - setCurrentDirectory "camp" - r <- io - setCurrentDirectory d - return r +inCamp = inDir "camp" hunk ./darcs2camp.hs 138 -checkConsistent x y = do xs <- getDirectoryContents x - ys <- getDirectoryContents y - let xs' = filter (`notElem` [".", ".."]) $ sort xs - ys' = filter (`notElem` [".", ".."]) $ sort ys - unless (xs' == ys') $ - error ("Inconsistent: " ++ show x) - mapM_ f xs' +checkConsistent x y + = do xs <- getDirectoryContents x + ys <- getDirectoryContents y + let xs' = filter (`notElem` [".", ".."]) $ sort xs + ys' = filter (`notElem` [".", "..", "_camp"]) $ sort ys + unless (xs' == ys') $ + error ("Inconsistent: " ++ show x) + mapM_ f xs' hunk ./darcs2camp.hs 225 -handlePrim' (ChangePref {}) = return (unsafeCoerce Camp.Patch.Sequence.Nil) +handlePrim' (ChangePref {}) = return nil + +nil :: Camp.Patch.Sequence.Seq Camp.Patch.Primitive.Primitive from to +nil = unsafeCoerce Camp.Patch.Sequence.Nil addfile ./Setup.hs hunk ./Setup.hs 1 + +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + addfile ./darcs2camp.cabal hunk ./darcs2camp.cabal 1 +Name: darcs2camp +Version: 0.1 +License: BSD3 +License-File: LICENSE +Copyright: 2008 Ian Lynagh +Author: Ian Lynagh +Maintainer: Ian Lynagh +Synopsis: darcs2camp +Description: + darcs2camp +Category: Development +Build-Type: Simple +Cabal-Version: >=1.2 + +Executable darcs2camp + Main-Is: darcs2camp.hs + + Ghc-Options: -Wall -fwarn-tabs -Werror + + Build-Depends: base, bytestring, camp-core, camp-repository, darcs, + directory, filepath, mtl, old-time, process + + Extensions: ScopedTypeVariables + hunk ./darcs2camp.hs 6 +import qualified Camp.Patch.MegaPatch hunk ./darcs2camp.hs 19 +import Darcs.Patch.Info hunk ./darcs2camp.hs 24 -import FastPackedString hunk ./darcs2camp.hs 35 +import System.Time hunk ./darcs2camp.hs 106 - NamedP pi _ patch -> + NamedP pinfo _ patch -> hunk ./darcs2camp.hs 113 - Camp.Record.recordMegaPatch r n prims + let shortDesc = BSC.pack $ just_name pinfo + longDesc = BSC.pack $ unlines $ pi_log pinfo + author = BSC.pack $ just_author pinfo + date = toClockTime $ pi_date pinfo + mi = Camp.Patch.MegaPatch.MetaInfo + shortDesc longDesc author date + Camp.Record.recordMegaPatch r n mi prims hunk ./darcs2camp.hs 167 - inCamp $ applyCamp campPrims + inCamp $ Camp.Patch.Apply.applyFully campPrims hunk ./darcs2camp.hs 191 -applyCamp :: Camp.Patch.Sequence.Seq Camp.Patch.Primitive.Primitive from to - -> IO () -applyCamp Camp.Patch.Sequence.Nil = return () -applyCamp (Camp.Patch.Sequence.Cons p ps) = do Camp.Patch.Apply.apply p - applyCamp ps - hunk ./darcs2camp.hs 222 - (BSC.pack (unpackPS old)) - (BSC.pack (unpackPS new)) + (BSC.fromChunks [old]) + (BSC.fromChunks [new]) hunk ./darcs2camp.hs 6 +import Camp.InRepoFileName as InRepoFileName hunk ./darcs2camp.hs 197 - = do let from' = fn2fp from - to' = fn2fp to - isDir <- doesDirectoryExist ("camp" from') + = do let from' = InRepoFileName.fromString $ fn2fp from + to' = InRepoFileName.fromString $ fn2fp to + isDir <- doesDirectoryExist + ("camp" InRepoFileName.toFilePath from') hunk ./darcs2camp.hs 205 - = return (singleton (Camp.Patch.Primitive.RmDir (fn2fp fn))) + = do let fn' = InRepoFileName.fromString $ fn2fp fn + return (singleton (Camp.Patch.Primitive.RmDir fn')) hunk ./darcs2camp.hs 208 - = return (singleton (Camp.Patch.Primitive.AddDir (fn2fp fn))) + = do let fn' = InRepoFileName.fromString $ fn2fp fn + return (singleton (Camp.Patch.Primitive.AddDir fn')) hunk ./darcs2camp.hs 211 - = return (singleton (Camp.Patch.Primitive.RmFile (fn2fp fn))) + = do let fn' = InRepoFileName.fromString $ fn2fp fn + return (singleton (Camp.Patch.Primitive.RmFile fn')) hunk ./darcs2camp.hs 214 - = return (singleton (Camp.Patch.Primitive.AddFile (fn2fp fn))) + = do let fn' = InRepoFileName.fromString $ fn2fp fn + return (singleton (Camp.Patch.Primitive.AddFile fn')) hunk ./darcs2camp.hs 227 - = return (singleton (Camp.Patch.Primitive.Binary (fn2fp fn) - (BSC.fromChunks [old]) - (BSC.fromChunks [new]) - )) + = do let fn' = InRepoFileName.fromString $ fn2fp fn + return (singleton (Camp.Patch.Primitive.Binary fn' + (BSC.fromChunks [old]) + (BSC.fromChunks [new]) + )) hunk ./darcs2camp.hs 33 -import System.Exit hunk ./darcs2camp.hs 36 -import System.Process hunk ./darcs2camp.hs 46 - ec <- inCamp $ rawSystem "camp" ["init"] - case ec of - ExitSuccess -> return () - _ -> error "camp init failed" + inCamp $ do r <- Camp.Repository.createRepo + Camp.Repository.initialiseRepo r