-- Copyright (C) 2006-2007 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; if not, write to the Free Software Foundation,
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
module Darcs.Repository.InternalTypes
    ( Repository
    , PristineType(..)
    , AccessType(..)
    , SAccessType(..)
    , repoAccessType
    , repoCache
    , modifyCache
    , repoFormat
    , modifyRepoFormat
    , repoLocation
    , withRepoDir
    , repoPristineType
    , unsafeCoerceRepoType
    , unsafeCoercePatchType
    , unsafeCoerceR
    , unsafeCoerceU
    , unsafeEndTransaction
    , unsafeStartTransaction
    , mkRepo
    ) where

import Darcs.Prelude

import Darcs.Util.Cache ( Cache )
import Darcs.Repository.Format ( RepoFormat, unsafeWriteRepoFormat )
import Darcs.Repository.Paths ( formatPath )
import Darcs.Util.Path ( AbsoluteOrRemotePath, toPath )
import System.Directory ( withCurrentDirectory )
import Unsafe.Coerce ( unsafeCoerce )

data PristineType
  = NoPristine
  | PlainPristine
  | HashedPristine
    deriving ( Int -> PristineType -> ShowS
[PristineType] -> ShowS
PristineType -> String
(Int -> PristineType -> ShowS)
-> (PristineType -> String)
-> ([PristineType] -> ShowS)
-> Show PristineType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PristineType -> ShowS
showsPrec :: Int -> PristineType -> ShowS
$cshow :: PristineType -> String
show :: PristineType -> String
$cshowList :: [PristineType] -> ShowS
showList :: [PristineType] -> ShowS
Show, PristineType -> PristineType -> Bool
(PristineType -> PristineType -> Bool)
-> (PristineType -> PristineType -> Bool) -> Eq PristineType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PristineType -> PristineType -> Bool
== :: PristineType -> PristineType -> Bool
$c/= :: PristineType -> PristineType -> Bool
/= :: PristineType -> PristineType -> Bool
Eq )

data AccessType = RO | RW deriving (AccessType -> AccessType -> Bool
(AccessType -> AccessType -> Bool)
-> (AccessType -> AccessType -> Bool) -> Eq AccessType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AccessType -> AccessType -> Bool
== :: AccessType -> AccessType -> Bool
$c/= :: AccessType -> AccessType -> Bool
/= :: AccessType -> AccessType -> Bool
Eq)

data SAccessType (rt :: AccessType) where
  SRO :: SAccessType 'RO
  SRW :: SAccessType 'RW

-- |A @Repository@ is a token representing the state of a repository on disk.
-- It is parameterized by
--
-- [@rt@] the access type (whether we are in a transaction or not),
-- [@p@]  the patch type,
-- [@wU@] the witness for the unrecorded state (what's in the working tree now).
-- [@wR@] the witness for
--
--        * the recorded state when outside a transaction, or
--        * the tentative state when inside a transaction.
data Repository (rt :: AccessType) (p :: * -> * -> *) wU wR =
  Repo !String !RepoFormat !PristineType Cache (SAccessType rt)

type role Repository nominal nominal nominal nominal

repoLocation :: Repository rt p wU wR -> String
repoLocation :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation (Repo String
loc RepoFormat
_ PristineType
_ Cache
_ SAccessType rt
_) = String
loc

-- | Perform an action with the current working directory set to the
-- 'repoLocation'.
withRepoDir :: Repository rt p wU wR -> IO a -> IO a
withRepoDir :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository rt p wU wR
repo = String -> IO a -> IO a
forall a. String -> IO a -> IO a
withCurrentDirectory (Repository rt p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository rt p wU wR
repo)

repoFormat :: Repository rt p wU wR -> RepoFormat
repoFormat :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> RepoFormat
repoFormat (Repo String
_ RepoFormat
fmt PristineType
_ Cache
_ SAccessType rt
_) = RepoFormat
fmt

repoPristineType :: Repository rt p wU wR -> PristineType
repoPristineType :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> PristineType
repoPristineType (Repo String
_ RepoFormat
_ PristineType
pr Cache
_ SAccessType rt
_) = PristineType
pr

repoCache :: Repository rt p wU wR -> Cache
repoCache :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> Cache
repoCache (Repo String
_ RepoFormat
_ PristineType
_ Cache
c SAccessType rt
_) = Cache
c

modifyCache :: (Cache -> Cache) -> Repository rt p wU wR -> Repository rt p wU wR
modifyCache :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
(Cache -> Cache) -> Repository rt p wU wR -> Repository rt p wU wR
modifyCache Cache -> Cache
g (Repo String
l RepoFormat
f PristineType
p Cache
c SAccessType rt
a) = String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType rt
-> Repository rt p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType rt
-> Repository rt p wU wR
Repo String
l RepoFormat
f PristineType
p (Cache -> Cache
g Cache
c) SAccessType rt
a

repoAccessType :: Repository rt p wU wR -> SAccessType rt
repoAccessType :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> SAccessType rt
repoAccessType (Repo String
_ RepoFormat
_ PristineType
_ Cache
_ SAccessType rt
s) = SAccessType rt
s

unsafeCoerceRepoType :: Repository rt p wU wR -> Repository rt' p wU wR
unsafeCoerceRepoType :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR
       (rt' :: AccessType).
Repository rt p wU wR -> Repository rt' p wU wR
unsafeCoerceRepoType = Repository rt p wU wR -> Repository rt' p wU wR
forall a b. a -> b
unsafeCoerce

unsafeCoercePatchType :: Repository rt p wU wR -> Repository rt p' wU wR
unsafeCoercePatchType :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR
       (p' :: * -> * -> *).
Repository rt p wU wR -> Repository rt p' wU wR
unsafeCoercePatchType = Repository rt p wU wR -> Repository rt p' wU wR
forall a b. a -> b
unsafeCoerce

unsafeCoerceR :: Repository rt p wU wR -> Repository rt p wU wR'
unsafeCoerceR :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR wR'.
Repository rt p wU wR -> Repository rt p wU wR'
unsafeCoerceR = Repository rt p wU wR -> Repository rt p wU wR'
forall a b. a -> b
unsafeCoerce

unsafeCoerceU :: Repository rt p wU wR -> Repository rt p wU' wR
unsafeCoerceU :: forall (rt :: AccessType) (p :: * -> * -> *) wU wR wU'.
Repository rt p wU wR -> Repository rt p wU' wR
unsafeCoerceU = Repository rt p wU wR -> Repository rt p wU' wR
forall a b. a -> b
unsafeCoerce

-- | Both 'unsafeStartTransaction' and 'unsafeEndTransaction' are "unsafe" in
-- the sense that they merely "coerce" the type but do not actually perform the
-- steps ('IO' actions) required to start or end a transaction (this is done by
-- 'revertRepositoryChanges' and 'finalizeRepositoryChanges'). Technically this
-- is not an actual coercion like with e.g. 'unsafeCoerceR', due to the
-- singleton typed member, but in practical terms it is no less unsafe, because
-- 'RO' vs. 'RW' changes whether @wR@ refers to the recorded or the tentative
-- state, respectively. In particular, you will get different results if you
-- are inside a transaction and read the patchset with a "coerced" Repository
-- of access type 'RO. The same holds for other state that is modified in a
-- transaction, like the pending patch or the rebase state.
unsafeStartTransaction :: Repository 'RO p wU wR -> Repository 'RW p wU wR
unsafeStartTransaction :: forall (p :: * -> * -> *) wU wR.
Repository 'RO p wU wR -> Repository 'RW p wU wR
unsafeStartTransaction (Repo String
l RepoFormat
f PristineType
p Cache
c SAccessType 'RO
SRO) = String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType 'RW
-> Repository 'RW p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType rt
-> Repository rt p wU wR
Repo String
l RepoFormat
f PristineType
p Cache
c SAccessType 'RW
SRW

unsafeEndTransaction :: Repository 'RW p wU wR -> Repository 'RO p wU wR
unsafeEndTransaction :: forall (p :: * -> * -> *) wU wR.
Repository 'RW p wU wR -> Repository 'RO p wU wR
unsafeEndTransaction (Repo String
l RepoFormat
f PristineType
p Cache
c SAccessType 'RW
SRW) = String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType 'RO
-> Repository 'RO p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType rt
-> Repository rt p wU wR
Repo String
l RepoFormat
f PristineType
p Cache
c SAccessType 'RO
SRO

mkRepo :: AbsoluteOrRemotePath -> RepoFormat -> PristineType -> Cache -> Repository 'RO p wU wR
mkRepo :: forall (p :: * -> * -> *) wU wR.
AbsoluteOrRemotePath
-> RepoFormat -> PristineType -> Cache -> Repository 'RO p wU wR
mkRepo AbsoluteOrRemotePath
p RepoFormat
f PristineType
pr Cache
c = String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType 'RO
-> Repository 'RO p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType rt
-> Repository rt p wU wR
Repo (AbsoluteOrRemotePath -> String
forall a. FilePathOrURL a => a -> String
toPath AbsoluteOrRemotePath
p) RepoFormat
f PristineType
pr Cache
c SAccessType 'RO
SRO

modifyRepoFormat
  :: (RepoFormat -> RepoFormat)
  -> Repository 'RW p wU wR
  -> IO (Repository 'RW p wU wR)
modifyRepoFormat :: forall (p :: * -> * -> *) wU wR.
(RepoFormat -> RepoFormat)
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
modifyRepoFormat RepoFormat -> RepoFormat
f (Repo String
l RepoFormat
fmt PristineType
p Cache
c SAccessType 'RW
a) = do
  let fmt' :: RepoFormat
fmt' = RepoFormat -> RepoFormat
f RepoFormat
fmt
  RepoFormat -> String -> IO ()
unsafeWriteRepoFormat RepoFormat
fmt' String
formatPath
  Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Repository 'RW p wU wR -> IO (Repository 'RW p wU wR))
-> Repository 'RW p wU wR -> IO (Repository 'RW p wU wR)
forall a b. (a -> b) -> a -> b
$ String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType 'RW
-> Repository 'RW p wU wR
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
String
-> RepoFormat
-> PristineType
-> Cache
-> SAccessType rt
-> Repository rt p wU wR
Repo String
l RepoFormat
fmt' PristineType
p Cache
c SAccessType 'RW
a