{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}

--   Copyright (C) 2003-2004 Jan Scheffczyk and David Roundy
--
--   This program is free software; you can redistribute it and/or modify
--   it under the terms of the GNU General Public License as published by
--   the Free Software Foundation; either version 2, or (at your option)
--   any later version.
--
--   This program is distributed in the hope that it will be useful,
--   but WITHOUT ANY WARRANTY; without even the implied warranty of
--   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--   GNU General Public License for more details.
--
--   You should have received a copy of the GNU General Public License
--   along with this program; see the file COPYING.  If not, write to
--   the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--   Boston, MA 02110-1301, USA.

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

-- | population of an empty repository
initPop :: Population
initPop = Pop idpatchinfo (PopDir i [])
 where i = Info {nameI          = BC.singleton '.',
                 modifiedByI    = idpatchinfo,
                 modifiedHowI   = DullDir,
                 createdByI     = Nothing,
                 creationNameI  = Just (BC.singleton '.')}

-- | apply a patchset to a population
applyPatchSetPop :: RepoPatch p => PatchSet p C(x) -> Population -> Population
applyPatchSetPop ps pop = applyPatchesPop (reverseRL $ concatRL ps) pop

-- | apply Patches to a population
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)
-- | get the pristine population from a repo
getRepoPop :: FilePath -> IO Population
getRepoPop repobasedir
 = withRepositoryDirectory [] repobasedir $- \repository -> do
      pinfo <- (head . mapRL info . concatRL) `liftM` read_repo repository
      -- pinfo is the latest patchinfo
      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

-- Routines for pulling data conveniently out of a Population

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