src/Darcs/Population.hs

   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>"