#include "gadts.h"
module Darcs.Population ( Population, patchChanges, applyToPop,
getPopFrom,
setPopState,
DirMark(..),
getRepoPop, getRepoPopVersion,
modified_to_xml,
lookup_pop, lookup_creation_pop,
) where
import qualified Data.ByteString.Char8 as BC ( unpack, singleton, pack )
import Data.Maybe ( catMaybes )
import Darcs.Utils ( withCurrentDirectory )
import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )
import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, norm_path )
import Darcs.Patch ( RepoPatch, applyToPop, patchcontents, patchChanges,
Effect, effect )
import Darcs.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL )
import Darcs.Patch.Info ( PatchInfo, idpatchinfo, to_xml )
import Darcs.Patch.Set ( PatchSet )
import Darcs.Sealed ( Sealed(..), seal, unseal )
import Darcs.Repository ( withRepositoryDirectory, ($-), read_repo )
import Darcs.Repository.Pristine ( identifyPristine, getPristinePop )
import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..),
setPopState, getPopFrom )
import Printer ( empty, text, ($$), (<>), Doc )
import Control.Monad ( liftM )
#include "impossible.h"
initPop :: Population
initPop = Pop idpatchinfo (PopDir i [])
where i = Info {nameI = BC.singleton '.',
modifiedByI = idpatchinfo,
modifiedHowI = DullDir,
createdByI = Nothing,
creationNameI = Just (BC.singleton '.')}
applyPatchSetPop :: RepoPatch p => PatchSet p C(x) -> Population -> Population
applyPatchSetPop ps pop = applyPatchesPop (reverseRL $ concatRL ps) pop
applyPatchesPop :: Effect p => FL (PatchInfoAnd p) C(x y) -> Population -> Population
applyPatchesPop NilFL = id
applyPatchesPop (hp:>:hps) = applyPatchesPop hps .
applyToPop (info hp) (effect $ patchcontents $ hopefully hp)
getRepoPop :: FilePath -> IO Population
getRepoPop repobasedir
= withRepositoryDirectory [] repobasedir $- \repository -> do
pinfo <- (head . mapRL info . concatRL) `liftM` read_repo repository
mp <- withCurrentDirectory repobasedir $
identifyPristine >>= getPristinePop pinfo
case mp of
(Just pop) -> return pop
(Nothing) -> getRepoPopVersion repobasedir pinfo
getRepoPopVersion :: FilePath -> PatchInfo -> IO Population
getRepoPopVersion repobasedir pinfo = withRepositoryDirectory [] repobasedir $- \repository ->
do pips <- concatRL `liftM` read_repo repository
return $ (unseal applyPatchSetPop) (mkPatchSet $ dropWhileRL ((/=pinfo).info) pips) initPop
where mkPatchSet (Sealed xs) = seal $ xs :<: NilRL
dropWhileRL :: (FORALL(x y) a C(x y) -> Bool) -> RL a C(r v) -> Sealed (RL a C(r))
dropWhileRL _ NilRL = seal NilRL
dropWhileRL p xs@(x:<:xs')
| p x = dropWhileRL p xs'
| otherwise = seal xs
lookup_pop :: FilePath -> Population -> Maybe Population
lookup_pop f p = lookup_pop' (BC.unpack $ fn2ps $ fp2fn f) p
lookup_pop' :: String -> Population -> Maybe Population
lookup_pop' f p@(Pop _ (PopFile i))
| BC.unpack (nameI i) == f = Just p
| otherwise = Nothing
lookup_pop' d p@(Pop pinfo (PopDir i c))
| BC.unpack (nameI i) == "." =
case catMaybes $ map (lookup_pop' (dropDS d).(Pop pinfo)) c of
[apop] -> Just apop
[] -> Nothing
_ -> impossible
| BC.unpack (nameI i) == takeWhile (/='/') d =
case dropWhile (=='/') $ dropWhile (/='/') d of
"" -> Just p
d' -> case catMaybes $ map (lookup_pop' d'.(Pop pinfo)) c of
[apop] -> Just apop
[] -> Nothing
_ -> impossible
| otherwise = Nothing
where dropDS ('.':'/':f) = dropDS f
dropDS f = f
lookup_creation_pop :: PatchInfo -> FilePath -> Population -> Maybe Population
lookup_creation_pop pinfo f p = lookup_creation_pop' pinfo (BC.unpack $ fn2ps $ fp2fn f) p
lookup_creation_pop' :: PatchInfo -> String -> Population -> Maybe Population
lookup_creation_pop' b a (Pop pinfo pp) = (Pop pinfo) `fmap` lcp pp
where lcp p@(PopFile i)
| fixname `fmap` creationNameI i == f && createdByI i == who = Just p
| otherwise = Nothing
lcp p@(PopDir i c)
| fixname `fmap` creationNameI i == f && createdByI i == who = Just p
| otherwise = case catMaybes $ map lcp c of
[apop] -> Just apop
_ -> Nothing
fixname = BC.pack . fn2fp . norm_path . fp2fn . BC.unpack
f = Just $ BC.pack $ fn2fp $ norm_path $ fp2fn a
who = Just b
modified_to_xml :: Info -> Doc
modified_to_xml i | modifiedHowI i == DullDir = empty
| modifiedHowI i == DullFile = empty
modified_to_xml i = text "<modified>"
$$ text "<modified_how>" <> text (show (modifiedHowI i)) <>
text "</modified_how>"
$$ to_xml (modifiedByI i)
$$ text "</modified>"