1 {-# OPTIONS_GHC -cpp #-} 2 {-# LANGUAGE CPP #-} 3 4 -- Copyright (C) 2003-2004 Jan Scheffczyk and David Roundy 5 -- 6 -- This program is free software; you can redistribute it and/or modify 7 -- it under the terms of the GNU General Public License as published by 8 -- the Free Software Foundation; either version 2, or (at your option) 9 -- any later version. 10 -- 11 -- This program is distributed in the hope that it will be useful, 12 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 13 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 -- GNU General Public License for more details. 15 -- 16 -- You should have received a copy of the GNU General Public License 17 -- along with this program; see the file COPYING. If not, write to 18 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 19 -- Boston, MA 02110-1301, USA. 20 21 #include "gadts.h" 22 23 module Darcs.Population ( Population, patchChanges, applyToPop, 24 getPopFrom, 25 setPopState, 26 DirMark(..), 27 getRepoPop, getRepoPopVersion, 28 modified_to_xml, 29 lookup_pop, lookup_creation_pop, 30 ) where 31 32 import qualified Data.ByteString.Char8 as BC ( unpack, singleton, pack ) 33 import Data.Maybe ( catMaybes ) 34 import Darcs.Utils ( withCurrentDirectory ) 35 36 import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) 37 import Darcs.Patch.FileName ( fn2fp, fp2fn, fn2ps, norm_path ) 38 import Darcs.Patch ( RepoPatch, applyToPop, patchcontents, patchChanges, 39 Effect, effect ) 40 import Darcs.Ordered ( FL(..), RL(..), reverseRL, concatRL, mapRL ) 41 import Darcs.Patch.Info ( PatchInfo, idpatchinfo, to_xml ) 42 import Darcs.Patch.Set ( PatchSet ) 43 import Darcs.Sealed ( Sealed(..), seal, unseal ) 44 import Darcs.Repository ( withRepositoryDirectory, ($-), read_repo ) 45 import Darcs.Repository.Pristine ( identifyPristine, getPristinePop ) 46 import Darcs.PopulationData ( Population(..), PopTree(..), Info(..), DirMark(..), 47 setPopState, getPopFrom ) 48 import Printer ( empty, text, ($$), (<>), Doc ) 49 import Control.Monad ( liftM ) 50 51 #include "impossible.h" 52 53 -- | population of an empty repository 54 initPop :: Population 55 initPop = Pop idpatchinfo (PopDir i []) 56 where i = Info {nameI = BC.singleton '.', 57 modifiedByI = idpatchinfo, 58 modifiedHowI = DullDir, 59 createdByI = Nothing, 60 creationNameI = Just (BC.singleton '.')} 61 62 -- | apply a patchset to a population 63 applyPatchSetPop :: RepoPatch p => PatchSet p C(x) -> Population -> Population 64 applyPatchSetPop ps pop = applyPatchesPop (reverseRL $ concatRL ps) pop 65 66 -- | apply Patches to a population 67 applyPatchesPop :: Effect p => FL (PatchInfoAnd p) C(x y) -> Population -> Population 68 applyPatchesPop NilFL = id 69 applyPatchesPop (hp:>:hps) = applyPatchesPop hps . 70 applyToPop (info hp) (effect $ patchcontents $ hopefully hp) 71 -- | get the pristine population from a repo 72 getRepoPop :: FilePath -> IO Population 73 getRepoPop repobasedir 74 = withRepositoryDirectory [] repobasedir $- \repository -> do 75 pinfo <- (head . mapRL info . concatRL) `liftM` read_repo repository 76 -- pinfo is the latest patchinfo 77 mp <- withCurrentDirectory repobasedir $ 78 identifyPristine >>= getPristinePop pinfo 79 case mp of 80 (Just pop) -> return pop 81 (Nothing) -> getRepoPopVersion repobasedir pinfo 82 83 getRepoPopVersion :: FilePath -> PatchInfo -> IO Population 84 getRepoPopVersion repobasedir pinfo = withRepositoryDirectory [] repobasedir $- \repository -> 85 do pips <- concatRL `liftM` read_repo repository 86 return $ (unseal applyPatchSetPop) (mkPatchSet $ dropWhileRL ((/=pinfo).info) pips) initPop 87 where mkPatchSet (Sealed xs) = seal $ xs :<: NilRL 88 dropWhileRL :: (FORALL(x y) a C(x y) -> Bool) -> RL a C(r v) -> Sealed (RL a C(r)) 89 dropWhileRL _ NilRL = seal NilRL 90 dropWhileRL p xs@(x:<:xs') 91 | p x = dropWhileRL p xs' 92 | otherwise = seal xs 93 94 -- Routines for pulling data conveniently out of a Population 95 96 lookup_pop :: FilePath -> Population -> Maybe Population 97 lookup_pop f p = lookup_pop' (BC.unpack $ fn2ps $ fp2fn f) p 98 99 lookup_pop' :: String -> Population -> Maybe Population 100 lookup_pop' f p@(Pop _ (PopFile i)) 101 | BC.unpack (nameI i) == f = Just p 102 | otherwise = Nothing 103 lookup_pop' d p@(Pop pinfo (PopDir i c)) 104 | BC.unpack (nameI i) == "." = 105 case catMaybes $ map (lookup_pop' (dropDS d).(Pop pinfo)) c of 106 [apop] -> Just apop 107 [] -> Nothing 108 _ -> impossible 109 | BC.unpack (nameI i) == takeWhile (/='/') d = 110 case dropWhile (=='/') $ dropWhile (/='/') d of 111 "" -> Just p 112 d' -> case catMaybes $ map (lookup_pop' d'.(Pop pinfo)) c of 113 [apop] -> Just apop 114 [] -> Nothing 115 _ -> impossible 116 | otherwise = Nothing 117 where dropDS ('.':'/':f) = dropDS f 118 dropDS f = f 119 120 lookup_creation_pop :: PatchInfo -> FilePath -> Population -> Maybe Population 121 lookup_creation_pop pinfo f p = lookup_creation_pop' pinfo (BC.unpack $ fn2ps $ fp2fn f) p 122 123 lookup_creation_pop' :: PatchInfo -> String -> Population -> Maybe Population 124 lookup_creation_pop' b a (Pop pinfo pp) = (Pop pinfo) `fmap` lcp pp 125 where lcp p@(PopFile i) 126 | fixname `fmap` creationNameI i == f && createdByI i == who = Just p 127 | otherwise = Nothing 128 lcp p@(PopDir i c) 129 | fixname `fmap` creationNameI i == f && createdByI i == who = Just p 130 | otherwise = case catMaybes $ map lcp c of 131 [apop] -> Just apop 132 _ -> Nothing 133 fixname = BC.pack . fn2fp . norm_path . fp2fn . BC.unpack 134 f = Just $ BC.pack $ fn2fp $ norm_path $ fp2fn a 135 who = Just b 136 137 modified_to_xml :: Info -> Doc 138 modified_to_xml i | modifiedHowI i == DullDir = empty 139 | modifiedHowI i == DullFile = empty 140 modified_to_xml i = text "<modified>" 141 $$ text "<modified_how>" <> text (show (modifiedHowI i)) <> 142 text "</modified_how>" 143 $$ to_xml (modifiedByI i) 144 $$ text "</modified>"