module Erebos.Storage (
    Storage, PartialStorage, StorageCompleteness,
    openStorage, memoryStorage,
    deriveEphemeralStorage, derivePartialStorage,

    Ref, PartialRef, RefDigest,
    refDigest,
    readRef, showRef, showRefDigest,
    refDigestFromByteString, hashToRefDigest,
    copyRef, partialRef, partialRefFromDigest,

    Object, PartialObject, Object'(..), RecItem, RecItem'(..),
    serializeObject, deserializeObject, deserializeObjects,
    ioLoadObject, ioLoadBytes,
    storeRawBytes, lazyLoadBytes,
    storeObject,
    collectObjects, collectStoredObjects,

    Head, HeadType(..),
    HeadTypeID, mkHeadTypeID,
    headId, headStorage, headRef, headObject, headStoredObject,
    loadHeads, loadHead, reloadHead,
    storeHead, replaceHead, updateHead, updateHead_,

    WatchedHead,
    watchHead, watchHeadWith, unwatchHead,

    MonadStorage(..),

    Storable(..), ZeroStorable(..),
    StorableText(..), StorableDate(..), StorableUUID(..),

    Store, StoreRec,
    evalStore, evalStoreObject,
    storeBlob, storeRec, storeZero,
    storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef,
    storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef,
    storeZRef,

    Load, LoadRec,
    evalLoad,
    loadCurrentRef, loadCurrentObject,
    loadRecCurrentRef, loadRecItems,

    loadBlob, loadRec, loadZero,
    loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef,
    loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef,
    loadTexts, loadBinaries, loadRefs, loadRawRefs,
    loadZRef,

    Stored,
    fromStored, storedRef,
    wrappedStore, wrappedLoad,
    copyStored,
    unsafeMapStored,

    StoreInfo(..), makeStoreInfo,

    StoredHistory,
    fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList,
    beginHistory, modifyHistory,
) where

import Control.Applicative
import Control.Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer

import Crypto.Hash

import Data.ByteString (ByteString)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Char
import Data.Function
import qualified Data.HashTable.IO as HT
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Ratio
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Text.Encoding.Error
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.Format
import Data.Time.LocalTime
import Data.Typeable
import Data.UUID (UUID)
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U

import System.Directory
import System.FilePath
import System.INotify
import System.IO.Error
import System.IO.Unsafe

import Erebos.Storage.Internal


type Storage = Storage' Complete
type PartialStorage = Storage' Partial

openStorage :: FilePath -> IO Storage
openStorage :: String -> IO Storage
openStorage String
path = do
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/objects"
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/heads"
    MVar ([(HeadTypeID, INotify)], WatchList Identity)
watchers <- ([(HeadTypeID, INotify)], WatchList Identity)
-> IO (MVar ([(HeadTypeID, INotify)], WatchList Identity))
forall a. a -> IO (MVar a)
newMVar ([], WatchID -> [WatchListItem Identity] -> WatchList Identity
forall (c :: * -> *). WatchID -> [WatchListItem c] -> WatchList c
WatchList WatchID
1 [])
    MVar (HashTable RealWorld RefDigest Generation)
refgen <- HashTable RealWorld RefDigest Generation
-> IO (MVar (HashTable RealWorld RefDigest Generation))
forall a. a -> IO (MVar a)
newMVar (HashTable RealWorld RefDigest Generation
 -> IO (MVar (HashTable RealWorld RefDigest Generation)))
-> IO (HashTable RealWorld RefDigest Generation)
-> IO (MVar (HashTable RealWorld RefDigest Generation))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (HashTable RealWorld RefDigest Generation)
IO (IOHashTable HashTable RefDigest Generation)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new
    MVar (HashTable RealWorld RefDigest [RefDigest])
refroots <- HashTable RealWorld RefDigest [RefDigest]
-> IO (MVar (HashTable RealWorld RefDigest [RefDigest]))
forall a. a -> IO (MVar a)
newMVar (HashTable RealWorld RefDigest [RefDigest]
 -> IO (MVar (HashTable RealWorld RefDigest [RefDigest])))
-> IO (HashTable RealWorld RefDigest [RefDigest])
-> IO (MVar (HashTable RealWorld RefDigest [RefDigest]))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (HashTable RealWorld RefDigest [RefDigest])
IO (IOHashTable HashTable RefDigest [RefDigest])
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new
    Storage -> IO Storage
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Storage -> IO Storage) -> Storage -> IO Storage
forall a b. (a -> b) -> a -> b
$ Storage
        { stBacking :: StorageBacking Identity
stBacking = String
-> MVar ([(HeadTypeID, INotify)], WatchList Identity)
-> StorageBacking Identity
forall (c :: * -> *).
String
-> MVar ([(HeadTypeID, INotify)], WatchList c) -> StorageBacking c
StorageDir String
path MVar ([(HeadTypeID, INotify)], WatchList Identity)
watchers
        , stParent :: Maybe Storage
stParent = Maybe Storage
forall a. Maybe a
Nothing
        , stRefGeneration :: MVar (IOHashTable HashTable RefDigest Generation)
stRefGeneration = MVar (HashTable RealWorld RefDigest Generation)
MVar (IOHashTable HashTable RefDigest Generation)
refgen
        , stRefRoots :: MVar (IOHashTable HashTable RefDigest [RefDigest])
stRefRoots = MVar (HashTable RealWorld RefDigest [RefDigest])
MVar (IOHashTable HashTable RefDigest [RefDigest])
refroots
        }

memoryStorage' :: IO (Storage' c')
memoryStorage' :: forall (c' :: * -> *). IO (Storage' c')
memoryStorage' = do
    StorageBacking c'
backing <- MVar [((HeadTypeID, HeadID), Ref' c')]
-> MVar (Map RefDigest ByteString)
-> MVar (Map RefDigest ScrubbedBytes)
-> MVar (WatchList c')
-> StorageBacking c'
forall (c :: * -> *).
MVar [((HeadTypeID, HeadID), Ref' c)]
-> MVar (Map RefDigest ByteString)
-> MVar (Map RefDigest ScrubbedBytes)
-> MVar (WatchList c)
-> StorageBacking c
StorageMemory (MVar [((HeadTypeID, HeadID), Ref' c')]
 -> MVar (Map RefDigest ByteString)
 -> MVar (Map RefDigest ScrubbedBytes)
 -> MVar (WatchList c')
 -> StorageBacking c')
-> IO (MVar [((HeadTypeID, HeadID), Ref' c')])
-> IO
     (MVar (Map RefDigest ByteString)
      -> MVar (Map RefDigest ScrubbedBytes)
      -> MVar (WatchList c')
      -> StorageBacking c')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((HeadTypeID, HeadID), Ref' c')]
-> IO (MVar [((HeadTypeID, HeadID), Ref' c')])
forall a. a -> IO (MVar a)
newMVar [] IO
  (MVar (Map RefDigest ByteString)
   -> MVar (Map RefDigest ScrubbedBytes)
   -> MVar (WatchList c')
   -> StorageBacking c')
-> IO (MVar (Map RefDigest ByteString))
-> IO
     (MVar (Map RefDigest ScrubbedBytes)
      -> MVar (WatchList c') -> StorageBacking c')
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map RefDigest ByteString -> IO (MVar (Map RefDigest ByteString))
forall a. a -> IO (MVar a)
newMVar Map RefDigest ByteString
forall k a. Map k a
M.empty IO
  (MVar (Map RefDigest ScrubbedBytes)
   -> MVar (WatchList c') -> StorageBacking c')
-> IO (MVar (Map RefDigest ScrubbedBytes))
-> IO (MVar (WatchList c') -> StorageBacking c')
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map RefDigest ScrubbedBytes
-> IO (MVar (Map RefDigest ScrubbedBytes))
forall a. a -> IO (MVar a)
newMVar Map RefDigest ScrubbedBytes
forall k a. Map k a
M.empty IO (MVar (WatchList c') -> StorageBacking c')
-> IO (MVar (WatchList c')) -> IO (StorageBacking c')
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WatchList c' -> IO (MVar (WatchList c'))
forall a. a -> IO (MVar a)
newMVar (WatchID -> [WatchListItem c'] -> WatchList c'
forall (c :: * -> *). WatchID -> [WatchListItem c] -> WatchList c
WatchList WatchID
1 [])
    MVar (HashTable RealWorld RefDigest Generation)
refgen <- HashTable RealWorld RefDigest Generation
-> IO (MVar (HashTable RealWorld RefDigest Generation))
forall a. a -> IO (MVar a)
newMVar (HashTable RealWorld RefDigest Generation
 -> IO (MVar (HashTable RealWorld RefDigest Generation)))
-> IO (HashTable RealWorld RefDigest Generation)
-> IO (MVar (HashTable RealWorld RefDigest Generation))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (HashTable RealWorld RefDigest Generation)
IO (IOHashTable HashTable RefDigest Generation)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new
    MVar (HashTable RealWorld RefDigest [RefDigest])
refroots <- HashTable RealWorld RefDigest [RefDigest]
-> IO (MVar (HashTable RealWorld RefDigest [RefDigest]))
forall a. a -> IO (MVar a)
newMVar (HashTable RealWorld RefDigest [RefDigest]
 -> IO (MVar (HashTable RealWorld RefDigest [RefDigest])))
-> IO (HashTable RealWorld RefDigest [RefDigest])
-> IO (MVar (HashTable RealWorld RefDigest [RefDigest]))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (HashTable RealWorld RefDigest [RefDigest])
IO (IOHashTable HashTable RefDigest [RefDigest])
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new
    Storage' c' -> IO (Storage' c')
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Storage' c' -> IO (Storage' c'))
-> Storage' c' -> IO (Storage' c')
forall a b. (a -> b) -> a -> b
$ Storage
        { stBacking :: StorageBacking c'
stBacking = StorageBacking c'
backing
        , stParent :: Maybe Storage
stParent = Maybe Storage
forall a. Maybe a
Nothing
        , stRefGeneration :: MVar (IOHashTable HashTable RefDigest Generation)
stRefGeneration = MVar (HashTable RealWorld RefDigest Generation)
MVar (IOHashTable HashTable RefDigest Generation)
refgen
        , stRefRoots :: MVar (IOHashTable HashTable RefDigest [RefDigest])
stRefRoots = MVar (HashTable RealWorld RefDigest [RefDigest])
MVar (IOHashTable HashTable RefDigest [RefDigest])
refroots
        }

memoryStorage :: IO Storage
memoryStorage :: IO Storage
memoryStorage = IO Storage
forall (c' :: * -> *). IO (Storage' c')
memoryStorage'

deriveEphemeralStorage :: Storage -> IO Storage
deriveEphemeralStorage :: Storage -> IO Storage
deriveEphemeralStorage Storage
parent = do
    Storage
st <- IO Storage
memoryStorage
    Storage -> IO Storage
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Storage -> IO Storage) -> Storage -> IO Storage
forall a b. (a -> b) -> a -> b
$ Storage
st { stParent = Just parent }

derivePartialStorage :: Storage -> IO PartialStorage
derivePartialStorage :: Storage -> IO PartialStorage
derivePartialStorage Storage
parent = do
    PartialStorage
st <- IO PartialStorage
forall (c' :: * -> *). IO (Storage' c')
memoryStorage'
    PartialStorage -> IO PartialStorage
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PartialStorage -> IO PartialStorage)
-> PartialStorage -> IO PartialStorage
forall a b. (a -> b) -> a -> b
$ PartialStorage
st { stParent = Just parent }

type Ref = Ref' Complete
type PartialRef = Ref' Partial

zeroRef :: Storage' c -> Ref' c
zeroRef :: forall (c :: * -> *). Storage' c -> Ref' c
zeroRef Storage' c
s = Storage' c -> RefDigest -> Ref' c
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref Storage' c
s (Digest Blake2b_256 -> RefDigest
RefDigest Digest Blake2b_256
h)
    where h :: Digest Blake2b_256
h = case ByteString -> Maybe (Digest Blake2b_256)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString (ByteString -> Maybe (Digest Blake2b_256))
-> ByteString -> Maybe (Digest Blake2b_256)
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
B.replicate (Blake2b_256 -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize (Blake2b_256 -> Int) -> Blake2b_256 -> Int
forall a b. (a -> b) -> a -> b
$ Digest Blake2b_256 -> Blake2b_256
forall a. Digest a -> a
digestAlgo Digest Blake2b_256
h) Word8
0 of
                   Maybe (Digest Blake2b_256)
Nothing -> String -> Digest Blake2b_256
forall a. HasCallStack => String -> a
error (String -> Digest Blake2b_256) -> String -> Digest Blake2b_256
forall a b. (a -> b) -> a -> b
$ String
"Failed to create zero hash"
                   Just Digest Blake2b_256
h' -> Digest Blake2b_256
h'
          digestAlgo :: Digest a -> a
          digestAlgo :: forall a. Digest a -> a
digestAlgo = Digest a -> a
forall a. HasCallStack => a
undefined

isZeroRef :: Ref' c -> Bool
isZeroRef :: forall (c :: * -> *). Ref' c -> Bool
isZeroRef (Ref Storage' c
_ RefDigest
h) = (Word8 -> Bool) -> [Word8] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==Word8
0) ([Word8] -> Bool) -> [Word8] -> Bool
forall a b. (a -> b) -> a -> b
$ RefDigest -> [Word8]
forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack RefDigest
h


refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c))
refFromDigest :: forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe (Ref' c))
refFromDigest Storage' c
st RefDigest
dgst = (ByteString -> Ref' c) -> Maybe ByteString -> Maybe (Ref' c)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ref' c -> ByteString -> Ref' c
forall a b. a -> b -> a
const (Ref' c -> ByteString -> Ref' c) -> Ref' c -> ByteString -> Ref' c
forall a b. (a -> b) -> a -> b
$ Storage' c -> RefDigest -> Ref' c
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref Storage' c
st RefDigest
dgst) (Maybe ByteString -> Maybe (Ref' c))
-> IO (Maybe ByteString) -> IO (Maybe (Ref' c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage' c -> RefDigest -> IO (Maybe ByteString)
forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe ByteString)
ioLoadBytesFromStorage Storage' c
st RefDigest
dgst

readRef :: Storage -> ByteString -> IO (Maybe Ref)
readRef :: Storage -> ByteString -> IO (Maybe Ref)
readRef Storage
s ByteString
b =
    case ByteString -> Maybe RefDigest
readRefDigest ByteString
b of
         Maybe RefDigest
Nothing -> Maybe Ref -> IO (Maybe Ref)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Ref
forall a. Maybe a
Nothing
         Just RefDigest
dgst -> Storage -> RefDigest -> IO (Maybe Ref)
forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe (Ref' c))
refFromDigest Storage
s RefDigest
dgst

copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c'))
copyRef' :: forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Ref' c -> IO (c (Ref' c'))
copyRef' Storage' c'
st ref' :: Ref' c
ref'@(Ref Storage' c
_ RefDigest
dgst) = Storage' c' -> RefDigest -> IO (Maybe (Ref' c'))
forall (c :: * -> *).
Storage' c -> RefDigest -> IO (Maybe (Ref' c))
refFromDigest Storage' c'
st RefDigest
dgst IO (Maybe (Ref' c'))
-> (Maybe (Ref' c') -> IO (c (Ref' c'))) -> IO (c (Ref' c'))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case Just Ref' c'
ref -> c (Ref' c') -> IO (c (Ref' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (Ref' c') -> IO (c (Ref' c')))
-> c (Ref' c') -> IO (c (Ref' c'))
forall a b. (a -> b) -> a -> b
$ Ref' c' -> c (Ref' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return Ref' c'
ref
                                                                Maybe (Ref' c')
Nothing  -> IO (c (Ref' c'))
doCopy
    where doCopy :: IO (c (Ref' c'))
doCopy = do c (Object' c)
mbobj' <- Ref' c -> IO (c (Object' c))
forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> IO (c (Object' c))
ioLoadObject Ref' c
ref'
                      c (c (Object' c'))
mbobj <- c (IO (c (Object' c'))) -> IO (c (c (Object' c')))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => c (m a) -> m (c a)
sequence (c (IO (c (Object' c'))) -> IO (c (c (Object' c'))))
-> c (IO (c (Object' c'))) -> IO (c (c (Object' c')))
forall a b. (a -> b) -> a -> b
$ Storage' c' -> Object' c -> IO (c (Object' c'))
forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Object' c -> IO (c (Object' c'))
copyObject' Storage' c'
st (Object' c -> IO (c (Object' c')))
-> c (Object' c) -> c (IO (c (Object' c')))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c (Object' c)
mbobj'
                      c (IO (Ref' c')) -> IO (c (Ref' c'))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => c (m a) -> m (c a)
sequence (c (IO (Ref' c')) -> IO (c (Ref' c')))
-> c (IO (Ref' c')) -> IO (c (Ref' c'))
forall a b. (a -> b) -> a -> b
$ Storage' c' -> Object' c' -> IO (Ref' c')
forall (c :: * -> *). Storage' c -> Object' c -> IO (Ref' c)
unsafeStoreObject Storage' c'
st (Object' c' -> IO (Ref' c')) -> c (Object' c') -> c (IO (Ref' c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c (c (Object' c')) -> c (Object' c')
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join c (c (Object' c'))
mbobj

copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c'))
copyObject' :: forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Object' c -> IO (c (Object' c'))
copyObject' Storage' c'
_ (Blob ByteString
bs) = c (Object' c') -> IO (c (Object' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (Object' c') -> IO (c (Object' c')))
-> c (Object' c') -> IO (c (Object' c'))
forall a b. (a -> b) -> a -> b
$ Object' c' -> c (Object' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object' c' -> c (Object' c')) -> Object' c' -> c (Object' c')
forall a b. (a -> b) -> a -> b
$ ByteString -> Object' c'
forall (c :: * -> *). ByteString -> Object' c
Blob ByteString
bs
copyObject' Storage' c'
st (Rec [(ByteString, RecItem' c)]
rs) = ([(ByteString, RecItem' c')] -> Object' c')
-> c [(ByteString, RecItem' c')] -> c (Object' c')
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ByteString, RecItem' c')] -> Object' c'
forall (c :: * -> *). [(ByteString, RecItem' c)] -> Object' c
Rec (c [(ByteString, RecItem' c')] -> c (Object' c'))
-> ([c (ByteString, RecItem' c')] -> c [(ByteString, RecItem' c')])
-> [c (ByteString, RecItem' c')]
-> c (Object' c')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [c (ByteString, RecItem' c')] -> c [(ByteString, RecItem' c')]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([c (ByteString, RecItem' c')] -> c (Object' c'))
-> IO [c (ByteString, RecItem' c')] -> IO (c (Object' c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c')))
-> [(ByteString, RecItem' c)] -> IO [c (ByteString, RecItem' c')]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c'))
copyItem [(ByteString, RecItem' c)]
rs
    where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c'))
          copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c'))
copyItem (ByteString
n, RecItem' c
item) = (RecItem' c' -> (ByteString, RecItem' c'))
-> c (RecItem' c') -> c (ByteString, RecItem' c')
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString
n,) (c (RecItem' c') -> c (ByteString, RecItem' c'))
-> IO (c (RecItem' c')) -> IO (c (ByteString, RecItem' c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case RecItem' c
item of
              RecItem' c
RecEmpty -> c (RecItem' c') -> IO (c (RecItem' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (RecItem' c') -> IO (c (RecItem' c')))
-> c (RecItem' c') -> IO (c (RecItem' c'))
forall a b. (a -> b) -> a -> b
$ RecItem' c' -> c (RecItem' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c' -> c (RecItem' c')) -> RecItem' c' -> c (RecItem' c')
forall a b. (a -> b) -> a -> b
$ RecItem' c'
forall (c :: * -> *). RecItem' c
RecEmpty
              RecInt Integer
x -> c (RecItem' c') -> IO (c (RecItem' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (RecItem' c') -> IO (c (RecItem' c')))
-> c (RecItem' c') -> IO (c (RecItem' c'))
forall a b. (a -> b) -> a -> b
$ RecItem' c' -> c (RecItem' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c' -> c (RecItem' c')) -> RecItem' c' -> c (RecItem' c')
forall a b. (a -> b) -> a -> b
$ Integer -> RecItem' c'
forall (c :: * -> *). Integer -> RecItem' c
RecInt Integer
x
              RecNum Rational
x -> c (RecItem' c') -> IO (c (RecItem' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (RecItem' c') -> IO (c (RecItem' c')))
-> c (RecItem' c') -> IO (c (RecItem' c'))
forall a b. (a -> b) -> a -> b
$ RecItem' c' -> c (RecItem' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c' -> c (RecItem' c')) -> RecItem' c' -> c (RecItem' c')
forall a b. (a -> b) -> a -> b
$ Rational -> RecItem' c'
forall (c :: * -> *). Rational -> RecItem' c
RecNum Rational
x
              RecText Text
x -> c (RecItem' c') -> IO (c (RecItem' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (RecItem' c') -> IO (c (RecItem' c')))
-> c (RecItem' c') -> IO (c (RecItem' c'))
forall a b. (a -> b) -> a -> b
$ RecItem' c' -> c (RecItem' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c' -> c (RecItem' c')) -> RecItem' c' -> c (RecItem' c')
forall a b. (a -> b) -> a -> b
$ Text -> RecItem' c'
forall (c :: * -> *). Text -> RecItem' c
RecText Text
x
              RecBinary ByteString
x -> c (RecItem' c') -> IO (c (RecItem' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (RecItem' c') -> IO (c (RecItem' c')))
-> c (RecItem' c') -> IO (c (RecItem' c'))
forall a b. (a -> b) -> a -> b
$ RecItem' c' -> c (RecItem' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c' -> c (RecItem' c')) -> RecItem' c' -> c (RecItem' c')
forall a b. (a -> b) -> a -> b
$ ByteString -> RecItem' c'
forall (c :: * -> *). ByteString -> RecItem' c
RecBinary ByteString
x
              RecDate ZonedTime
x -> c (RecItem' c') -> IO (c (RecItem' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (RecItem' c') -> IO (c (RecItem' c')))
-> c (RecItem' c') -> IO (c (RecItem' c'))
forall a b. (a -> b) -> a -> b
$ RecItem' c' -> c (RecItem' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c' -> c (RecItem' c')) -> RecItem' c' -> c (RecItem' c')
forall a b. (a -> b) -> a -> b
$ ZonedTime -> RecItem' c'
forall (c :: * -> *). ZonedTime -> RecItem' c
RecDate ZonedTime
x
              RecUUID UUID
x -> c (RecItem' c') -> IO (c (RecItem' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (RecItem' c') -> IO (c (RecItem' c')))
-> c (RecItem' c') -> IO (c (RecItem' c'))
forall a b. (a -> b) -> a -> b
$ RecItem' c' -> c (RecItem' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c' -> c (RecItem' c')) -> RecItem' c' -> c (RecItem' c')
forall a b. (a -> b) -> a -> b
$ UUID -> RecItem' c'
forall (c :: * -> *). UUID -> RecItem' c
RecUUID UUID
x
              RecRef Ref' c
x -> (Ref' c' -> RecItem' c') -> c (Ref' c') -> c (RecItem' c')
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref' c' -> RecItem' c'
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (c (Ref' c') -> c (RecItem' c'))
-> IO (c (Ref' c')) -> IO (c (RecItem' c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage' c' -> Ref' c -> IO (c (Ref' c'))
forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Ref' c -> IO (c (Ref' c'))
copyRef' Storage' c'
st Ref' c
x
copyObject' Storage' c'
_ Object' c
ZeroObject = c (Object' c') -> IO (c (Object' c'))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (Object' c') -> IO (c (Object' c')))
-> c (Object' c') -> IO (c (Object' c'))
forall a b. (a -> b) -> a -> b
$ Object' c' -> c (Object' c')
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return Object' c'
forall (c :: * -> *). Object' c
ZeroObject

copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
copyRef :: forall (c :: * -> *) (c' :: * -> *) (m :: * -> *).
(StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
copyRef Storage' c'
st Ref' c
ref' = IO (LoadResult c (Ref' c')) -> m (LoadResult c (Ref' c'))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LoadResult c (Ref' c')) -> m (LoadResult c (Ref' c')))
-> IO (LoadResult c (Ref' c')) -> m (LoadResult c (Ref' c'))
forall a b. (a -> b) -> a -> b
$ c (Ref' c') -> LoadResult c (Ref' c')
forall a. c a -> LoadResult c a
forall (compl :: * -> *) a.
StorageCompleteness compl =>
compl a -> LoadResult compl a
returnLoadResult (c (Ref' c') -> LoadResult c (Ref' c'))
-> IO (c (Ref' c')) -> IO (LoadResult c (Ref' c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage' c' -> Ref' c -> IO (c (Ref' c'))
forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Ref' c -> IO (c (Ref' c'))
copyRef' Storage' c'
st Ref' c
ref'

copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
copyObject :: forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
copyObject Storage' c'
st Object' c
obj' = c (Object' c') -> LoadResult c (Object' c')
forall a. c a -> LoadResult c a
forall (compl :: * -> *) a.
StorageCompleteness compl =>
compl a -> LoadResult compl a
returnLoadResult (c (Object' c') -> LoadResult c (Object' c'))
-> IO (c (Object' c')) -> IO (LoadResult c (Object' c'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage' c' -> Object' c -> IO (c (Object' c'))
forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Object' c -> IO (c (Object' c'))
copyObject' Storage' c'
st Object' c
obj'

partialRef :: PartialStorage -> Ref -> PartialRef
partialRef :: PartialStorage -> Ref -> PartialRef
partialRef PartialStorage
st (Ref Storage
_ RefDigest
dgst) = PartialStorage -> RefDigest -> PartialRef
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref PartialStorage
st RefDigest
dgst

partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef
partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef
partialRefFromDigest PartialStorage
st RefDigest
dgst = PartialStorage -> RefDigest -> PartialRef
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref PartialStorage
st RefDigest
dgst


data Object' c
    = Blob ByteString
    | Rec [(ByteString, RecItem' c)]
    | ZeroObject
    deriving (Int -> Object' c -> String -> String
[Object' c] -> String -> String
Object' c -> String
(Int -> Object' c -> String -> String)
-> (Object' c -> String)
-> ([Object' c] -> String -> String)
-> Show (Object' c)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (c :: * -> *). Int -> Object' c -> String -> String
forall (c :: * -> *). [Object' c] -> String -> String
forall (c :: * -> *). Object' c -> String
$cshowsPrec :: forall (c :: * -> *). Int -> Object' c -> String -> String
showsPrec :: Int -> Object' c -> String -> String
$cshow :: forall (c :: * -> *). Object' c -> String
show :: Object' c -> String
$cshowList :: forall (c :: * -> *). [Object' c] -> String -> String
showList :: [Object' c] -> String -> String
Show)

type Object = Object' Complete
type PartialObject = Object' Partial

data RecItem' c
    = RecEmpty
    | RecInt Integer
    | RecNum Rational
    | RecText Text
    | RecBinary ByteString
    | RecDate ZonedTime
    | RecUUID UUID
    | RecRef (Ref' c)
    deriving (Int -> RecItem' c -> String -> String
[RecItem' c] -> String -> String
RecItem' c -> String
(Int -> RecItem' c -> String -> String)
-> (RecItem' c -> String)
-> ([RecItem' c] -> String -> String)
-> Show (RecItem' c)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (c :: * -> *). Int -> RecItem' c -> String -> String
forall (c :: * -> *). [RecItem' c] -> String -> String
forall (c :: * -> *). RecItem' c -> String
$cshowsPrec :: forall (c :: * -> *). Int -> RecItem' c -> String -> String
showsPrec :: Int -> RecItem' c -> String -> String
$cshow :: forall (c :: * -> *). RecItem' c -> String
show :: RecItem' c -> String
$cshowList :: forall (c :: * -> *). [RecItem' c] -> String -> String
showList :: [RecItem' c] -> String -> String
Show)

type RecItem = RecItem' Complete

serializeObject :: Object' c -> BL.ByteString
serializeObject :: forall (c :: * -> *). Object' c -> ByteString
serializeObject = \case
    Blob ByteString
cnt -> [ByteString] -> ByteString
BL.fromChunks [String -> ByteString
BC.pack String
"blob ", String -> ByteString
BC.pack (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
cnt), Char -> ByteString
BC.singleton Char
'\n', ByteString
cnt]
    Rec [(ByteString, RecItem' c)]
rec -> let cnt :: ByteString
cnt = [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ((ByteString, RecItem' c) -> [ByteString])
-> [(ByteString, RecItem' c)] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((ByteString -> RecItem' c -> [ByteString])
-> (ByteString, RecItem' c) -> [ByteString]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> RecItem' c -> [ByteString]
forall (c :: * -> *). ByteString -> RecItem' c -> [ByteString]
serializeRecItem) [(ByteString, RecItem' c)]
rec
                in [ByteString] -> ByteString
BL.fromChunks [String -> ByteString
BC.pack String
"rec ", String -> ByteString
BC.pack (Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
cnt), Char -> ByteString
BC.singleton Char
'\n'] ByteString -> ByteString -> ByteString
`BL.append` ByteString
cnt
    Object' c
ZeroObject -> ByteString
BL.empty

-- |Serializes and stores object data without ony dependencies, so is safe only
-- if all the referenced objects are already stored or reference is partial.
unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c)
unsafeStoreObject :: forall (c :: * -> *). Storage' c -> Object' c -> IO (Ref' c)
unsafeStoreObject Storage' c
storage = \case
    Object' c
ZeroObject -> Ref' c -> IO (Ref' c)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ref' c -> IO (Ref' c)) -> Ref' c -> IO (Ref' c)
forall a b. (a -> b) -> a -> b
$ Storage' c -> Ref' c
forall (c :: * -> *). Storage' c -> Ref' c
zeroRef Storage' c
storage
    Object' c
obj -> Storage' c -> ByteString -> IO (Ref' c)
forall (c :: * -> *). Storage' c -> ByteString -> IO (Ref' c)
unsafeStoreRawBytes Storage' c
storage (ByteString -> IO (Ref' c)) -> ByteString -> IO (Ref' c)
forall a b. (a -> b) -> a -> b
$ Object' c -> ByteString
forall (c :: * -> *). Object' c -> ByteString
serializeObject Object' c
obj

storeObject :: PartialStorage -> PartialObject -> IO PartialRef
storeObject :: PartialStorage -> PartialObject -> IO PartialRef
storeObject = PartialStorage -> PartialObject -> IO PartialRef
forall (c :: * -> *). Storage' c -> Object' c -> IO (Ref' c)
unsafeStoreObject

storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
storeRawBytes :: PartialStorage -> ByteString -> IO PartialRef
storeRawBytes = PartialStorage -> ByteString -> IO PartialRef
forall (c :: * -> *). Storage' c -> ByteString -> IO (Ref' c)
unsafeStoreRawBytes

serializeRecItem :: ByteString -> RecItem' c -> [ByteString]
serializeRecItem :: forall (c :: * -> *). ByteString -> RecItem' c -> [ByteString]
serializeRecItem ByteString
name (RecItem' c
RecEmpty) = [ByteString
name, String -> ByteString
BC.pack String
":e", Char -> ByteString
BC.singleton Char
' ', Char -> ByteString
BC.singleton Char
'\n']
serializeRecItem ByteString
name (RecInt Integer
x) = [ByteString
name, String -> ByteString
BC.pack String
":i", Char -> ByteString
BC.singleton Char
' ', String -> ByteString
BC.pack (Integer -> String
forall a. Show a => a -> String
show Integer
x), Char -> ByteString
BC.singleton Char
'\n']
serializeRecItem ByteString
name (RecNum Rational
x) = [ByteString
name, String -> ByteString
BC.pack String
":n", Char -> ByteString
BC.singleton Char
' ', String -> ByteString
BC.pack (Rational -> String
showRatio Rational
x), Char -> ByteString
BC.singleton Char
'\n']
serializeRecItem ByteString
name (RecText Text
x) = [ByteString
name, String -> ByteString
BC.pack String
":t", Char -> ByteString
BC.singleton Char
' ', ByteString
escaped, Char -> ByteString
BC.singleton Char
'\n']
    where escaped :: ByteString
escaped = (Char -> ByteString) -> ByteString -> ByteString
BC.concatMap Char -> ByteString
escape (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
x
          escape :: Char -> ByteString
escape Char
'\n' = String -> ByteString
BC.pack String
"\n\t"
          escape Char
c    = Char -> ByteString
BC.singleton Char
c
serializeRecItem ByteString
name (RecBinary ByteString
x) = [ByteString
name, String -> ByteString
BC.pack String
":b ", ByteString -> ByteString
forall ba. ByteArrayAccess ba => ba -> ByteString
showHex ByteString
x, Char -> ByteString
BC.singleton Char
'\n']
serializeRecItem ByteString
name (RecDate ZonedTime
x) = [ByteString
name, String -> ByteString
BC.pack String
":d", Char -> ByteString
BC.singleton Char
' ', String -> ByteString
BC.pack (TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s %z" ZonedTime
x), Char -> ByteString
BC.singleton Char
'\n']
serializeRecItem ByteString
name (RecUUID UUID
x) = [ByteString
name, String -> ByteString
BC.pack String
":u", Char -> ByteString
BC.singleton Char
' ', UUID -> ByteString
U.toASCIIBytes UUID
x, Char -> ByteString
BC.singleton Char
'\n']
serializeRecItem ByteString
name (RecRef Ref' c
x) = [ByteString
name, String -> ByteString
BC.pack String
":r ", Ref' c -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef Ref' c
x, Char -> ByteString
BC.singleton Char
'\n']

lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c)
lazyLoadObject :: forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> LoadResult c (Object' c)
lazyLoadObject = c (Object' c) -> LoadResult c (Object' c)
forall a. c a -> LoadResult c a
forall (compl :: * -> *) a.
StorageCompleteness compl =>
compl a -> LoadResult compl a
returnLoadResult (c (Object' c) -> LoadResult c (Object' c))
-> (Ref' c -> c (Object' c)) -> Ref' c -> LoadResult c (Object' c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (c (Object' c)) -> c (Object' c)
forall a. IO a -> a
unsafePerformIO (IO (c (Object' c)) -> c (Object' c))
-> (Ref' c -> IO (c (Object' c))) -> Ref' c -> c (Object' c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref' c -> IO (c (Object' c))
forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> IO (c (Object' c))
ioLoadObject

ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c))
ioLoadObject :: forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> IO (c (Object' c))
ioLoadObject Ref' c
ref | Ref' c -> Bool
forall (c :: * -> *). Ref' c -> Bool
isZeroRef Ref' c
ref = c (Object' c) -> IO (c (Object' c))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (Object' c) -> IO (c (Object' c)))
-> c (Object' c) -> IO (c (Object' c))
forall a b. (a -> b) -> a -> b
$ Object' c -> c (Object' c)
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return Object' c
forall (c :: * -> *). Object' c
ZeroObject
ioLoadObject ref :: Ref' c
ref@(Ref Storage' c
st RefDigest
rhash) = do
    c ByteString
file' <- Ref' c -> IO (c ByteString)
forall (compl :: * -> *).
StorageCompleteness compl =>
Ref' compl -> IO (compl ByteString)
ioLoadBytes Ref' c
ref
    c (Object' c) -> IO (c (Object' c))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c (Object' c) -> IO (c (Object' c)))
-> c (Object' c) -> IO (c (Object' c))
forall a b. (a -> b) -> a -> b
$ do
        ByteString
file <- c ByteString
file'
        let chash :: RefDigest
chash = ByteString -> RefDigest
hashToRefDigest ByteString
file
        Bool -> c () -> c ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RefDigest
chash RefDigest -> RefDigest -> Bool
forall a. Eq a => a -> a -> Bool
/= RefDigest
rhash) (c () -> c ()) -> c () -> c ()
forall a b. (a -> b) -> a -> b
$ String -> c ()
forall a. HasCallStack => String -> a
error (String -> c ()) -> String -> c ()
forall a b. (a -> b) -> a -> b
$ String
"Hash mismatch on object " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack (Ref' c -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef Ref' c
ref) {- TODO throw -}
        Object' c -> c (Object' c)
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object' c -> c (Object' c)) -> Object' c -> c (Object' c)
forall a b. (a -> b) -> a -> b
$ case Except String (Object' c, ByteString)
-> Either String (Object' c, ByteString)
forall e a. Except e a -> Either e a
runExcept (Except String (Object' c, ByteString)
 -> Either String (Object' c, ByteString))
-> Except String (Object' c, ByteString)
-> Either String (Object' c, ByteString)
forall a b. (a -> b) -> a -> b
$ Storage' c -> ByteString -> Except String (Object' c, ByteString)
forall (c :: * -> *).
Storage' c -> ByteString -> Except String (Object' c, ByteString)
unsafeDeserializeObject Storage' c
st ByteString
file of
                      Left String
err -> String -> Object' c
forall a. HasCallStack => String -> a
error (String -> Object' c) -> String -> Object' c
forall a b. (a -> b) -> a -> b
$ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", ref " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack (Ref' c -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef Ref' c
ref) {- TODO throw -}
                      Right (Object' c
x, ByteString
rest) | ByteString -> Bool
BL.null ByteString
rest -> Object' c
x
                                      | Bool
otherwise -> String -> Object' c
forall a. HasCallStack => String -> a
error (String -> Object' c) -> String -> Object' c
forall a b. (a -> b) -> a -> b
$ String
"Superfluous content after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack (Ref' c -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef Ref' c
ref) {- TODO throw -}

lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString
lazyLoadBytes :: forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> LoadResult c ByteString
lazyLoadBytes Ref' c
ref | Ref' c -> Bool
forall (c :: * -> *). Ref' c -> Bool
isZeroRef Ref' c
ref = c ByteString -> LoadResult c ByteString
forall a. c a -> LoadResult c a
forall (compl :: * -> *) a.
StorageCompleteness compl =>
compl a -> LoadResult compl a
returnLoadResult (ByteString -> c ByteString
forall a. a -> c a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
BL.empty :: c BL.ByteString)
lazyLoadBytes Ref' c
ref = c ByteString -> LoadResult c ByteString
forall a. c a -> LoadResult c a
forall (compl :: * -> *) a.
StorageCompleteness compl =>
compl a -> LoadResult compl a
returnLoadResult (c ByteString -> LoadResult c ByteString)
-> c ByteString -> LoadResult c ByteString
forall a b. (a -> b) -> a -> b
$ IO (c ByteString) -> c ByteString
forall a. IO a -> a
unsafePerformIO (IO (c ByteString) -> c ByteString)
-> IO (c ByteString) -> c ByteString
forall a b. (a -> b) -> a -> b
$ Ref' c -> IO (c ByteString)
forall (compl :: * -> *).
StorageCompleteness compl =>
Ref' compl -> IO (compl ByteString)
ioLoadBytes Ref' c
ref

unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString)
unsafeDeserializeObject :: forall (c :: * -> *).
Storage' c -> ByteString -> Except String (Object' c, ByteString)
unsafeDeserializeObject Storage' c
_  ByteString
bytes | ByteString -> Bool
BL.null ByteString
bytes = (Object' c, ByteString)
-> ExceptT String Identity (Object' c, ByteString)
forall a. a -> ExceptT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object' c
forall (c :: * -> *). Object' c
ZeroObject, ByteString
bytes)
unsafeDeserializeObject Storage' c
st ByteString
bytes =
    case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BLC.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') ByteString
bytes of
        (ByteString
line, ByteString
rest) | Just (ByteString
otype, Int
len) <- ByteString -> Maybe (ByteString, Int)
splitObjPrefix ByteString
line -> do
            let (ByteString
content, ByteString
next) = (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ByteString -> ByteString
BL.toStrict ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> (ByteString, ByteString)
BL.splitAt (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BL.drop Int64
1 ByteString
rest
            Bool -> ExceptT String Identity ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ExceptT String Identity ())
-> Bool -> ExceptT String Identity ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
content Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len
            (,ByteString
next) (Object' c -> (Object' c, ByteString))
-> ExceptT String Identity (Object' c)
-> ExceptT String Identity (Object' c, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ByteString
otype of
                 ByteString
_ | ByteString
otype ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"blob" -> Object' c -> ExceptT String Identity (Object' c)
forall a. a -> ExceptT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object' c -> ExceptT String Identity (Object' c))
-> Object' c -> ExceptT String Identity (Object' c)
forall a b. (a -> b) -> a -> b
$ ByteString -> Object' c
forall (c :: * -> *). ByteString -> Object' c
Blob ByteString
content
                   | ByteString
otype ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"rec" -> ExceptT String Identity (Object' c)
-> ([(ByteString, RecItem' c)]
    -> ExceptT String Identity (Object' c))
-> Maybe [(ByteString, RecItem' c)]
-> ExceptT String Identity (Object' c)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ExceptT String Identity (Object' c)
forall a. String -> ExceptT String Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String Identity (Object' c))
-> String -> ExceptT String Identity (Object' c)
forall a b. (a -> b) -> a -> b
$ String
"Malformed record item ")
                                                   (Object' c -> ExceptT String Identity (Object' c)
forall a. a -> ExceptT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object' c -> ExceptT String Identity (Object' c))
-> ([(ByteString, RecItem' c)] -> Object' c)
-> [(ByteString, RecItem' c)]
-> ExceptT String Identity (Object' c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ByteString, RecItem' c)] -> Object' c
forall (c :: * -> *). [(ByteString, RecItem' c)] -> Object' c
Rec) (Maybe [(ByteString, RecItem' c)]
 -> ExceptT String Identity (Object' c))
-> Maybe [(ByteString, RecItem' c)]
-> ExceptT String Identity (Object' c)
forall a b. (a -> b) -> a -> b
$ [Maybe (ByteString, RecItem' c)]
-> Maybe [(ByteString, RecItem' c)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Maybe (ByteString, RecItem' c)]
 -> Maybe [(ByteString, RecItem' c)])
-> [Maybe (ByteString, RecItem' c)]
-> Maybe [(ByteString, RecItem' c)]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe (ByteString, RecItem' c))
-> [ByteString] -> [Maybe (ByteString, RecItem' c)]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Maybe (ByteString, RecItem' c)
parseRecLine ([ByteString] -> [Maybe (ByteString, RecItem' c)])
-> [ByteString] -> [Maybe (ByteString, RecItem' c)]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString] -> [ByteString]
mergeCont [] ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BC.lines ByteString
content
                   | Bool
otherwise -> String -> ExceptT String Identity (Object' c)
forall a. String -> ExceptT String Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String Identity (Object' c))
-> String -> ExceptT String Identity (Object' c)
forall a b. (a -> b) -> a -> b
$ String
"Unknown object type"
        (ByteString, ByteString)
_ -> String -> ExceptT String Identity (Object' c, ByteString)
forall a. String -> ExceptT String Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String Identity (Object' c, ByteString))
-> String -> ExceptT String Identity (Object' c, ByteString)
forall a b. (a -> b) -> a -> b
$ String
"Malformed object"
    where splitObjPrefix :: ByteString -> Maybe (ByteString, Int)
splitObjPrefix ByteString
line = do
              [ByteString
otype, ByteString
tlen] <- [ByteString] -> Maybe [ByteString]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> Maybe [ByteString])
-> [ByteString] -> Maybe [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BLC.words ByteString
line
              (Int
len, ByteString
rest) <- ByteString -> Maybe (Int, ByteString)
BLC.readInt ByteString
tlen
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
BL.null ByteString
rest
              (ByteString, Int) -> Maybe (ByteString, Int)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
BL.toStrict ByteString
otype, Int
len)

          mergeCont :: [ByteString] -> [ByteString] -> [ByteString]
mergeCont [ByteString]
cs (ByteString
a:ByteString
b:[ByteString]
rest) | Just (Char
'\t', ByteString
b') <- ByteString -> Maybe (Char, ByteString)
BC.uncons ByteString
b = [ByteString] -> [ByteString] -> [ByteString]
mergeCont (ByteString
b'ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:String -> ByteString
BC.pack String
"\n"ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
cs) (ByteString
aByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
rest)
          mergeCont [ByteString]
cs (ByteString
a:[ByteString]
rest) = [ByteString] -> ByteString
B.concat (ByteString
a ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
cs) ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString] -> [ByteString]
mergeCont [] [ByteString]
rest
          mergeCont [ByteString]
_ [] = []

          parseRecLine :: ByteString -> Maybe (ByteString, RecItem' c)
parseRecLine ByteString
line = do
              Int
colon <- Char -> ByteString -> Maybe Int
BC.elemIndex Char
':' ByteString
line
              Int
space <- Char -> ByteString -> Maybe Int
BC.elemIndex Char
' ' ByteString
line
              Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
colon Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
space
              let name :: ByteString
name = Int -> ByteString -> ByteString
B.take Int
colon ByteString
line
                  itype :: ByteString
itype = Int -> ByteString -> ByteString
B.take (Int
spaceInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
colonInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop (Int
colonInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ByteString
line
                  content :: ByteString
content = Int -> ByteString -> ByteString
B.drop (Int
spaceInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ByteString
line

              RecItem' c
val <- case ByteString -> String
BC.unpack ByteString
itype of
                          String
"e" -> do Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
B.null ByteString
content
                                    RecItem' c -> Maybe (RecItem' c)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return RecItem' c
forall (c :: * -> *). RecItem' c
RecEmpty
                          String
"i" -> do (Integer
num, ByteString
rest) <- ByteString -> Maybe (Integer, ByteString)
BC.readInteger ByteString
content
                                    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
B.null ByteString
rest
                                    RecItem' c -> Maybe (RecItem' c)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c -> Maybe (RecItem' c))
-> RecItem' c -> Maybe (RecItem' c)
forall a b. (a -> b) -> a -> b
$ Integer -> RecItem' c
forall (c :: * -> *). Integer -> RecItem' c
RecInt Integer
num
                          String
"n" -> Rational -> RecItem' c
forall (c :: * -> *). Rational -> RecItem' c
RecNum (Rational -> RecItem' c) -> Maybe Rational -> Maybe (RecItem' c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe Rational
parseRatio ByteString
content
                          String
"t" -> RecItem' c -> Maybe (RecItem' c)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecItem' c -> Maybe (RecItem' c))
-> RecItem' c -> Maybe (RecItem' c)
forall a b. (a -> b) -> a -> b
$ Text -> RecItem' c
forall (c :: * -> *). Text -> RecItem' c
RecText (Text -> RecItem' c) -> Text -> RecItem' c
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
content
                          String
"b" -> ByteString -> RecItem' c
forall (c :: * -> *). ByteString -> RecItem' c
RecBinary (ByteString -> RecItem' c)
-> Maybe ByteString -> Maybe (RecItem' c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe ByteString
forall ba. ByteArray ba => ByteString -> Maybe ba
readHex ByteString
content
                          String
"d" -> ZonedTime -> RecItem' c
forall (c :: * -> *). ZonedTime -> RecItem' c
RecDate (ZonedTime -> RecItem' c) -> Maybe ZonedTime -> Maybe (RecItem' c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> TimeLocale -> String -> String -> Maybe ZonedTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale String
"%s %z" (ByteString -> String
BC.unpack ByteString
content)
                          String
"u" -> UUID -> RecItem' c
forall (c :: * -> *). UUID -> RecItem' c
RecUUID (UUID -> RecItem' c) -> Maybe UUID -> Maybe (RecItem' c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe UUID
U.fromASCIIBytes ByteString
content
                          String
"r" -> Ref' c -> RecItem' c
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef (Ref' c -> RecItem' c)
-> (RefDigest -> Ref' c) -> RefDigest -> RecItem' c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Storage' c -> RefDigest -> Ref' c
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref Storage' c
st (RefDigest -> RecItem' c) -> Maybe RefDigest -> Maybe (RecItem' c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe RefDigest
readRefDigest ByteString
content
                          String
_   -> Maybe (RecItem' c)
forall a. Maybe a
Nothing
              (ByteString, RecItem' c) -> Maybe (ByteString, RecItem' c)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
name, RecItem' c
val)

deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString)
deserializeObject :: PartialStorage
-> ByteString -> Except String (PartialObject, ByteString)
deserializeObject = PartialStorage
-> ByteString -> Except String (PartialObject, ByteString)
forall (c :: * -> *).
Storage' c -> ByteString -> Except String (Object' c, ByteString)
unsafeDeserializeObject

deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject]
deserializeObjects :: PartialStorage -> ByteString -> Except String [PartialObject]
deserializeObjects PartialStorage
_  ByteString
bytes | ByteString -> Bool
BL.null ByteString
bytes = [PartialObject] -> Except String [PartialObject]
forall a. a -> ExceptT String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
deserializeObjects PartialStorage
st ByteString
bytes = do (PartialObject
obj, ByteString
rest) <- PartialStorage
-> ByteString -> Except String (PartialObject, ByteString)
deserializeObject PartialStorage
st ByteString
bytes
                                 (PartialObject
objPartialObject -> [PartialObject] -> [PartialObject]
forall a. a -> [a] -> [a]
:) ([PartialObject] -> [PartialObject])
-> Except String [PartialObject] -> Except String [PartialObject]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartialStorage -> ByteString -> Except String [PartialObject]
deserializeObjects PartialStorage
st ByteString
rest


collectObjects :: Object -> [Object]
collectObjects :: Object -> [Object]
collectObjects Object
obj = Object
obj Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: (Stored Object -> Object) -> [Stored Object] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map Stored Object -> Object
forall a. Stored a -> a
fromStored (([Stored Object], Set RefDigest) -> [Stored Object]
forall a b. (a, b) -> a
fst (([Stored Object], Set RefDigest) -> [Stored Object])
-> ([Stored Object], Set RefDigest) -> [Stored Object]
forall a b. (a -> b) -> a -> b
$ Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
collectOtherStored Set RefDigest
forall a. Set a
S.empty Object
obj)

collectStoredObjects :: Stored Object -> [Stored Object]
collectStoredObjects :: Stored Object -> [Stored Object]
collectStoredObjects Stored Object
obj = Stored Object
obj Stored Object -> [Stored Object] -> [Stored Object]
forall a. a -> [a] -> [a]
: (([Stored Object], Set RefDigest) -> [Stored Object]
forall a b. (a, b) -> a
fst (([Stored Object], Set RefDigest) -> [Stored Object])
-> ([Stored Object], Set RefDigest) -> [Stored Object]
forall a b. (a -> b) -> a -> b
$ Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
collectOtherStored Set RefDigest
forall a. Set a
S.empty (Object -> ([Stored Object], Set RefDigest))
-> Object -> ([Stored Object], Set RefDigest)
forall a b. (a -> b) -> a -> b
$ Stored Object -> Object
forall a. Stored a -> a
fromStored Stored Object
obj)

collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
collectOtherStored Set RefDigest
seen (Rec [(ByteString, RecItem)]
items) = (RecItem
 -> ([Stored Object], Set RefDigest)
 -> ([Stored Object], Set RefDigest))
-> ([Stored Object], Set RefDigest)
-> [RecItem]
-> ([Stored Object], Set RefDigest)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RecItem
-> ([Stored Object], Set RefDigest)
-> ([Stored Object], Set RefDigest)
helper ([], Set RefDigest
seen) ([RecItem] -> ([Stored Object], Set RefDigest))
-> [RecItem] -> ([Stored Object], Set RefDigest)
forall a b. (a -> b) -> a -> b
$ ((ByteString, RecItem) -> RecItem)
-> [(ByteString, RecItem)] -> [RecItem]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, RecItem) -> RecItem
forall a b. (a, b) -> b
snd [(ByteString, RecItem)]
items
    where helper :: RecItem
-> ([Stored Object], Set RefDigest)
-> ([Stored Object], Set RefDigest)
helper (RecRef Ref
ref) ([Stored Object]
xs, Set RefDigest
s) | RefDigest
r <- Ref -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest Ref
ref
                                      , RefDigest
r RefDigest -> Set RefDigest -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set RefDigest
s
                                      = let o :: Stored Object
o = Ref -> Stored Object
forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
ref
                                            ([Stored Object]
xs', Set RefDigest
s') = Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
collectOtherStored (RefDigest -> Set RefDigest -> Set RefDigest
forall a. Ord a => a -> Set a -> Set a
S.insert RefDigest
r Set RefDigest
s) (Object -> ([Stored Object], Set RefDigest))
-> Object -> ([Stored Object], Set RefDigest)
forall a b. (a -> b) -> a -> b
$ Stored Object -> Object
forall a. Stored a -> a
fromStored Stored Object
o
                                         in ((Stored Object
o Stored Object -> [Stored Object] -> [Stored Object]
forall a. a -> [a] -> [a]
: [Stored Object]
xs') [Stored Object] -> [Stored Object] -> [Stored Object]
forall a. [a] -> [a] -> [a]
++ [Stored Object]
xs, Set RefDigest
s')
          helper RecItem
_          ([Stored Object]
xs, Set RefDigest
s) = ([Stored Object]
xs, Set RefDigest
s)
collectOtherStored Set RefDigest
seen Object
_ = ([], Set RefDigest
seen)


type Head = Head' Complete

headId :: Head a -> HeadID
headId :: forall a. Head a -> HeadID
headId (Head HeadID
uuid Stored' Identity a
_) = HeadID
uuid

headStorage :: Head a -> Storage
headStorage :: forall a. Head a -> Storage
headStorage = Ref -> Storage
forall (c :: * -> *). Ref' c -> Storage' c
refStorage (Ref -> Storage) -> (Head a -> Ref) -> Head a -> Storage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Head a -> Ref
forall a. Head a -> Ref
headRef

headRef :: Head a -> Ref
headRef :: forall a. Head a -> Ref
headRef (Head HeadID
_ Stored' Identity a
sx) = Stored' Identity a -> Ref
forall a. Stored a -> Ref
storedRef Stored' Identity a
sx

headObject :: Head a -> a
headObject :: forall a. Head a -> a
headObject (Head HeadID
_ Stored' Identity a
sx) = Stored' Identity a -> a
forall a. Stored a -> a
fromStored Stored' Identity a
sx

headStoredObject :: Head a -> Stored a
headStoredObject :: forall a. Head a -> Stored a
headStoredObject (Head HeadID
_ Stored' Identity a
sx) = Stored' Identity a
sx

deriving instance StorableUUID HeadID
deriving instance StorableUUID HeadTypeID

mkHeadTypeID :: String -> HeadTypeID
mkHeadTypeID :: String -> HeadTypeID
mkHeadTypeID = HeadTypeID -> (UUID -> HeadTypeID) -> Maybe UUID -> HeadTypeID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> HeadTypeID
forall a. HasCallStack => String -> a
error String
"Invalid head type ID") UUID -> HeadTypeID
HeadTypeID (Maybe UUID -> HeadTypeID)
-> (String -> Maybe UUID) -> String -> HeadTypeID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe UUID
U.fromString

class Storable a => HeadType a where
    headTypeID :: proxy a -> HeadTypeID


headTypePath :: FilePath -> HeadTypeID -> FilePath
headTypePath :: String -> HeadTypeID -> String
headTypePath String
spath (HeadTypeID UUID
tid) = String
spath String -> String -> String
</> String
"heads" String -> String -> String
</> UUID -> String
U.toString UUID
tid

headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
headPath :: String -> HeadTypeID -> HeadID -> String
headPath String
spath HeadTypeID
tid (HeadID UUID
hid) = String -> HeadTypeID -> String
headTypePath String
spath HeadTypeID
tid String -> String -> String
</> UUID -> String
U.toString UUID
hid

loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a]
loadHeads :: forall a (m :: * -> *).
(MonadIO m, HeadType a) =>
Storage -> m [Head a]
loadHeads s :: Storage
s@(Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
spath }}) = IO [Head a] -> m [Head a]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Head a] -> m [Head a]) -> IO [Head a] -> m [Head a]
forall a b. (a -> b) -> a -> b
$ do
    let hpath :: String
hpath = String -> HeadTypeID -> String
headTypePath String
spath (HeadTypeID -> String) -> HeadTypeID -> String
forall a b. (a -> b) -> a -> b
$ forall a (proxy :: * -> *). HeadType a => proxy a -> HeadTypeID
headTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy

    [String]
files <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool) -> (String -> String) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
hpath String -> String -> String
</>)) ([String] -> IO [String]) -> IO [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        (IOError -> Maybe ())
-> (() -> IO [String]) -> IO [String] -> IO [String]
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (\IOError
e -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (IOError -> Bool
isDoesNotExistError IOError
e)) (IO [String] -> () -> IO [String]
forall a b. a -> b -> a
const (IO [String] -> () -> IO [String])
-> IO [String] -> () -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
        (String -> IO [String]
getDirectoryContents String
hpath)
    ([Maybe (Head a)] -> [Head a])
-> IO [Maybe (Head a)] -> IO [Head a]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Head a)] -> [Head a]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe (Head a)] -> IO [Head a])
-> IO [Maybe (Head a)] -> IO [Head a]
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> IO (Maybe (Head a))) -> IO [Maybe (Head a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
files ((String -> IO (Maybe (Head a))) -> IO [Maybe (Head a)])
-> (String -> IO (Maybe (Head a))) -> IO [Maybe (Head a)]
forall a b. (a -> b) -> a -> b
$ \String
hname -> do
        case String -> Maybe UUID
U.fromString String
hname of
             Just UUID
hid -> do
                 (ByteString
h:[ByteString]
_) <- ByteString -> [ByteString]
BC.lines (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile (String
hpath String -> String -> String
</> String
hname)
                 Just Ref
ref <- Storage -> ByteString -> IO (Maybe Ref)
readRef Storage
s ByteString
h
                 Maybe (Head a) -> IO (Maybe (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Head a) -> IO (Maybe (Head a)))
-> Maybe (Head a) -> IO (Maybe (Head a))
forall a b. (a -> b) -> a -> b
$ Head a -> Maybe (Head a)
forall a. a -> Maybe a
Just (Head a -> Maybe (Head a)) -> Head a -> Maybe (Head a)
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head (UUID -> HeadID
HeadID UUID
hid) (Stored' Identity a -> Head a) -> Stored' Identity a -> Head a
forall a b. (a -> b) -> a -> b
$ Ref -> Stored' Identity a
forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
ref
             Maybe UUID
Nothing -> Maybe (Head a) -> IO (Maybe (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Head a)
forall a. Maybe a
Nothing
loadHeads Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageMemory { memHeads :: forall (c :: * -> *).
StorageBacking c -> MVar [((HeadTypeID, HeadID), Ref' c)]
memHeads = MVar [((HeadTypeID, HeadID), Ref)]
theads } } = IO [Head a] -> m [Head a]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Head a] -> m [Head a]) -> IO [Head a] -> m [Head a]
forall a b. (a -> b) -> a -> b
$ do
    let toHead :: ((HeadTypeID, HeadID), Ref) -> Maybe (Head a)
toHead ((HeadTypeID
tid, HeadID
hid), Ref
ref) | HeadTypeID
tid HeadTypeID -> HeadTypeID -> Bool
forall a. Eq a => a -> a -> Bool
== forall a (proxy :: * -> *). HeadType a => proxy a -> HeadTypeID
headTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy = Head a -> Maybe (Head a)
forall a. a -> Maybe a
Just (Head a -> Maybe (Head a)) -> Head a -> Maybe (Head a)
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid (Stored' Identity a -> Head a) -> Stored' Identity a -> Head a
forall a b. (a -> b) -> a -> b
$ Ref -> Stored' Identity a
forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
ref
                                 | Bool
otherwise                  = Maybe (Head a)
forall a. Maybe a
Nothing
    [Maybe (Head a)] -> [Head a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Head a)] -> [Head a])
-> ([((HeadTypeID, HeadID), Ref)] -> [Maybe (Head a)])
-> [((HeadTypeID, HeadID), Ref)]
-> [Head a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((HeadTypeID, HeadID), Ref) -> Maybe (Head a))
-> [((HeadTypeID, HeadID), Ref)] -> [Maybe (Head a)]
forall a b. (a -> b) -> [a] -> [b]
map ((HeadTypeID, HeadID), Ref) -> Maybe (Head a)
toHead ([((HeadTypeID, HeadID), Ref)] -> [Head a])
-> IO [((HeadTypeID, HeadID), Ref)] -> IO [Head a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar [((HeadTypeID, HeadID), Ref)]
-> IO [((HeadTypeID, HeadID), Ref)]
forall a. MVar a -> IO a
readMVar MVar [((HeadTypeID, HeadID), Ref)]
theads

loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a))
loadHead :: forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Storage -> HeadID -> m (Maybe (Head a))
loadHead s :: Storage
s@(Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
spath }}) HeadID
hid = IO (Maybe (Head a)) -> m (Maybe (Head a))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Head a)) -> m (Maybe (Head a)))
-> IO (Maybe (Head a)) -> m (Maybe (Head a))
forall a b. (a -> b) -> a -> b
$ do
    (IOError -> Maybe ())
-> (() -> IO (Maybe (Head a)))
-> IO (Maybe (Head a))
-> IO (Maybe (Head a))
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (IO (Maybe (Head a)) -> () -> IO (Maybe (Head a))
forall a b. a -> b -> a
const (IO (Maybe (Head a)) -> () -> IO (Maybe (Head a)))
-> IO (Maybe (Head a)) -> () -> IO (Maybe (Head a))
forall a b. (a -> b) -> a -> b
$ Maybe (Head a) -> IO (Maybe (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Head a)
forall a. Maybe a
Nothing) (IO (Maybe (Head a)) -> IO (Maybe (Head a)))
-> IO (Maybe (Head a)) -> IO (Maybe (Head a))
forall a b. (a -> b) -> a -> b
$ do
        (ByteString
h:[ByteString]
_) <- ByteString -> [ByteString]
BC.lines (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile (String -> HeadTypeID -> HeadID -> String
headPath String
spath (forall a (proxy :: * -> *). HeadType a => proxy a -> HeadTypeID
headTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy) HeadID
hid)
        Just Ref
ref <- Storage -> ByteString -> IO (Maybe Ref)
readRef Storage
s ByteString
h
        Maybe (Head a) -> IO (Maybe (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Head a) -> IO (Maybe (Head a)))
-> Maybe (Head a) -> IO (Maybe (Head a))
forall a b. (a -> b) -> a -> b
$ Head a -> Maybe (Head a)
forall a. a -> Maybe a
Just (Head a -> Maybe (Head a)) -> Head a -> Maybe (Head a)
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid (Stored' Identity a -> Head a) -> Stored' Identity a -> Head a
forall a b. (a -> b) -> a -> b
$ Ref -> Stored' Identity a
forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
ref
loadHead Storage { stBacking :: forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking = StorageMemory { memHeads :: forall (c :: * -> *).
StorageBacking c -> MVar [((HeadTypeID, HeadID), Ref' c)]
memHeads = MVar [((HeadTypeID, HeadID), Ref)]
theads } } HeadID
hid = IO (Maybe (Head a)) -> m (Maybe (Head a))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Head a)) -> m (Maybe (Head a)))
-> IO (Maybe (Head a)) -> m (Maybe (Head a))
forall a b. (a -> b) -> a -> b
$ do
    (Ref -> Head a) -> Maybe Ref -> Maybe (Head a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid (Stored' Identity a -> Head a)
-> (Ref -> Stored' Identity a) -> Ref -> Head a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref -> Stored' Identity a
forall a. Storable a => Ref -> Stored a
wrappedLoad) (Maybe Ref -> Maybe (Head a))
-> ([((HeadTypeID, HeadID), Ref)] -> Maybe Ref)
-> [((HeadTypeID, HeadID), Ref)]
-> Maybe (Head a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeadTypeID, HeadID) -> [((HeadTypeID, HeadID), Ref)] -> Maybe Ref
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (forall a (proxy :: * -> *). HeadType a => proxy a -> HeadTypeID
headTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy, HeadID
hid) ([((HeadTypeID, HeadID), Ref)] -> Maybe (Head a))
-> IO [((HeadTypeID, HeadID), Ref)] -> IO (Maybe (Head a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar [((HeadTypeID, HeadID), Ref)]
-> IO [((HeadTypeID, HeadID), Ref)]
forall a. MVar a -> IO a
readMVar MVar [((HeadTypeID, HeadID), Ref)]
theads

reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a))
reloadHead :: forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Head a -> m (Maybe (Head a))
reloadHead (Head HeadID
hid (Stored (Ref Storage
st RefDigest
_) a
_)) = Storage -> HeadID -> m (Maybe (Head' Identity a))
forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Storage -> HeadID -> m (Maybe (Head a))
loadHead Storage
st HeadID
hid

storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a)
storeHead :: forall a (m :: * -> *).
(MonadIO m, HeadType a) =>
Storage -> a -> m (Head a)
storeHead Storage
st a
obj = IO (Head a) -> m (Head a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Head a) -> m (Head a)) -> IO (Head a) -> m (Head a)
forall a b. (a -> b) -> a -> b
$ do
    let tid :: HeadTypeID
tid = forall a (proxy :: * -> *). HeadType a => proxy a -> HeadTypeID
headTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
    HeadID
hid <- UUID -> HeadID
HeadID (UUID -> HeadID) -> IO UUID -> IO HeadID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
U.nextRandom
    Stored a
stored <- Storage -> a -> IO (Stored a)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st a
obj
    case Storage -> StorageBacking Identity
forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking Storage
st of
         StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
spath } -> do
             Right () <- String
-> Maybe ByteString
-> ByteString
-> IO (Either (Maybe ByteString) ())
writeFileChecked (String -> HeadTypeID -> HeadID -> String
headPath String
spath HeadTypeID
tid HeadID
hid) Maybe ByteString
forall a. Maybe a
Nothing (ByteString -> IO (Either (Maybe ByteString) ()))
-> ByteString -> IO (Either (Maybe ByteString) ())
forall a b. (a -> b) -> a -> b
$
                 Ref -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef (Stored a -> Ref
forall a. Stored a -> Ref
storedRef Stored a
stored) ByteString -> ByteString -> ByteString
`B.append` Char -> ByteString
BC.singleton Char
'\n'
             () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         StorageMemory { memHeads :: forall (c :: * -> *).
StorageBacking c -> MVar [((HeadTypeID, HeadID), Ref' c)]
memHeads = MVar [((HeadTypeID, HeadID), Ref)]
theads } -> do
             MVar [((HeadTypeID, HeadID), Ref)]
-> ([((HeadTypeID, HeadID), Ref)]
    -> IO [((HeadTypeID, HeadID), Ref)])
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [((HeadTypeID, HeadID), Ref)]
theads (([((HeadTypeID, HeadID), Ref)]
  -> IO [((HeadTypeID, HeadID), Ref)])
 -> IO ())
-> ([((HeadTypeID, HeadID), Ref)]
    -> IO [((HeadTypeID, HeadID), Ref)])
-> IO ()
forall a b. (a -> b) -> a -> b
$ [((HeadTypeID, HeadID), Ref)] -> IO [((HeadTypeID, HeadID), Ref)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([((HeadTypeID, HeadID), Ref)] -> IO [((HeadTypeID, HeadID), Ref)])
-> ([((HeadTypeID, HeadID), Ref)] -> [((HeadTypeID, HeadID), Ref)])
-> [((HeadTypeID, HeadID), Ref)]
-> IO [((HeadTypeID, HeadID), Ref)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((HeadTypeID
tid, HeadID
hid), Stored a -> Ref
forall a. Stored a -> Ref
storedRef Stored a
stored) ((HeadTypeID, HeadID), Ref)
-> [((HeadTypeID, HeadID), Ref)] -> [((HeadTypeID, HeadID), Ref)]
forall a. a -> [a] -> [a]
:)
    Head a -> IO (Head a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Head a -> IO (Head a)) -> Head a -> IO (Head a)
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid Stored a
stored

replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a))
replaceHead :: forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a))
replaceHead prev :: Head a
prev@(Head HeadID
hid Stored' Identity a
pobj) Stored' Identity a
stored' = IO (Either (Maybe (Head a)) (Head a))
-> m (Either (Maybe (Head a)) (Head a))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Maybe (Head a)) (Head a))
 -> m (Either (Maybe (Head a)) (Head a)))
-> IO (Either (Maybe (Head a)) (Head a))
-> m (Either (Maybe (Head a)) (Head a))
forall a b. (a -> b) -> a -> b
$ do
    let st :: Storage
st = Head a -> Storage
forall a. Head a -> Storage
headStorage Head a
prev
        tid :: HeadTypeID
tid = forall a (proxy :: * -> *). HeadType a => proxy a -> HeadTypeID
headTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
    Stored' Identity a
stored <- Storage
-> Stored' Identity a
-> IO (LoadResult Identity (Stored' Identity a))
forall (c :: * -> *) (c' :: * -> *) (m :: * -> *) a.
(StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a))
copyStored Storage
st Stored' Identity a
stored'
    case Storage -> StorageBacking Identity
forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking Storage
st of
         StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
spath } -> do
             let filename :: String
filename = String -> HeadTypeID -> HeadID -> String
headPath String
spath HeadTypeID
tid HeadID
hid
                 showRefL :: Ref' c -> ByteString
showRefL Ref' c
r = Ref' c -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef Ref' c
r ByteString -> ByteString -> ByteString
`B.append` Char -> ByteString
BC.singleton Char
'\n'

             String
-> Maybe ByteString
-> ByteString
-> IO (Either (Maybe ByteString) ())
writeFileChecked String
filename (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Ref -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRefL (Ref -> ByteString) -> Ref -> ByteString
forall a b. (a -> b) -> a -> b
$ Head a -> Ref
forall a. Head a -> Ref
headRef Head a
prev) (Ref -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRefL (Ref -> ByteString) -> Ref -> ByteString
forall a b. (a -> b) -> a -> b
$ Stored' Identity a -> Ref
forall a. Stored a -> Ref
storedRef Stored' Identity a
stored) IO (Either (Maybe ByteString) ())
-> (Either (Maybe ByteString) ()
    -> IO (Either (Maybe (Head a)) (Head a)))
-> IO (Either (Maybe (Head a)) (Head a))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                 Left Maybe ByteString
Nothing -> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe (Head a)) (Head a)
 -> IO (Either (Maybe (Head a)) (Head a)))
-> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a b. (a -> b) -> a -> b
$ Maybe (Head a) -> Either (Maybe (Head a)) (Head a)
forall a b. a -> Either a b
Left Maybe (Head a)
forall a. Maybe a
Nothing
                 Left (Just ByteString
bs) -> do Just Ref
oref <- Storage -> ByteString -> IO (Maybe Ref)
readRef Storage
st (ByteString -> IO (Maybe Ref)) -> ByteString -> IO (Maybe Ref)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BC.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') ByteString
bs
                                      Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe (Head a)) (Head a)
 -> IO (Either (Maybe (Head a)) (Head a)))
-> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a b. (a -> b) -> a -> b
$ Maybe (Head a) -> Either (Maybe (Head a)) (Head a)
forall a b. a -> Either a b
Left (Maybe (Head a) -> Either (Maybe (Head a)) (Head a))
-> Maybe (Head a) -> Either (Maybe (Head a)) (Head a)
forall a b. (a -> b) -> a -> b
$ Head a -> Maybe (Head a)
forall a. a -> Maybe a
Just (Head a -> Maybe (Head a)) -> Head a -> Maybe (Head a)
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid (Stored' Identity a -> Head a) -> Stored' Identity a -> Head a
forall a b. (a -> b) -> a -> b
$ Ref -> Stored' Identity a
forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
oref
                 Right () -> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe (Head a)) (Head a)
 -> IO (Either (Maybe (Head a)) (Head a)))
-> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a b. (a -> b) -> a -> b
$ Head a -> Either (Maybe (Head a)) (Head a)
forall a b. b -> Either a b
Right (Head a -> Either (Maybe (Head a)) (Head a))
-> Head a -> Either (Maybe (Head a)) (Head a)
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid Stored' Identity a
stored

         StorageMemory { memHeads :: forall (c :: * -> *).
StorageBacking c -> MVar [((HeadTypeID, HeadID), Ref' c)]
memHeads = MVar [((HeadTypeID, HeadID), Ref)]
theads, memWatchers :: forall (c :: * -> *). StorageBacking c -> MVar (WatchList c)
memWatchers = MVar (WatchList Identity)
twatch } -> do
             Either (Maybe (Head a)) (Head a, [Ref -> IO ()])
res <- MVar [((HeadTypeID, HeadID), Ref)]
-> ([((HeadTypeID, HeadID), Ref)]
    -> IO
         ([((HeadTypeID, HeadID), Ref)],
          Either (Maybe (Head a)) (Head a, [Ref -> IO ()])))
-> IO (Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar [((HeadTypeID, HeadID), Ref)]
theads (([((HeadTypeID, HeadID), Ref)]
  -> IO
       ([((HeadTypeID, HeadID), Ref)],
        Either (Maybe (Head a)) (Head a, [Ref -> IO ()])))
 -> IO (Either (Maybe (Head a)) (Head a, [Ref -> IO ()])))
-> ([((HeadTypeID, HeadID), Ref)]
    -> IO
         ([((HeadTypeID, HeadID), Ref)],
          Either (Maybe (Head a)) (Head a, [Ref -> IO ()])))
-> IO (Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
forall a b. (a -> b) -> a -> b
$ \[((HeadTypeID, HeadID), Ref)]
hs -> do
                 [Ref -> IO ()]
ws <- (WatchListItem Identity -> Ref -> IO ())
-> [WatchListItem Identity] -> [Ref -> IO ()]
forall a b. (a -> b) -> [a] -> [b]
map WatchListItem Identity -> Ref -> IO ()
forall (c :: * -> *). WatchListItem c -> Ref' c -> IO ()
wlFun ([WatchListItem Identity] -> [Ref -> IO ()])
-> (WatchList Identity -> [WatchListItem Identity])
-> WatchList Identity
-> [Ref -> IO ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WatchListItem Identity -> Bool)
-> [WatchListItem Identity] -> [WatchListItem Identity]
forall a. (a -> Bool) -> [a] -> [a]
filter (((HeadTypeID, HeadID) -> (HeadTypeID, HeadID) -> Bool
forall a. Eq a => a -> a -> Bool
==(HeadTypeID
tid, HeadID
hid)) ((HeadTypeID, HeadID) -> Bool)
-> (WatchListItem Identity -> (HeadTypeID, HeadID))
-> WatchListItem Identity
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WatchListItem Identity -> (HeadTypeID, HeadID)
forall (c :: * -> *). WatchListItem c -> (HeadTypeID, HeadID)
wlHead) ([WatchListItem Identity] -> [WatchListItem Identity])
-> (WatchList Identity -> [WatchListItem Identity])
-> WatchList Identity
-> [WatchListItem Identity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WatchList Identity -> [WatchListItem Identity]
forall (c :: * -> *). WatchList c -> [WatchListItem c]
wlList (WatchList Identity -> [Ref -> IO ()])
-> IO (WatchList Identity) -> IO [Ref -> IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (WatchList Identity) -> IO (WatchList Identity)
forall a. MVar a -> IO a
readMVar MVar (WatchList Identity)
twatch
                 ([((HeadTypeID, HeadID), Ref)],
 Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
-> IO
     ([((HeadTypeID, HeadID), Ref)],
      Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([((HeadTypeID, HeadID), Ref)],
  Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
 -> IO
      ([((HeadTypeID, HeadID), Ref)],
       Either (Maybe (Head a)) (Head a, [Ref -> IO ()])))
-> ([((HeadTypeID, HeadID), Ref)],
    Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
-> IO
     ([((HeadTypeID, HeadID), Ref)],
      Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
forall a b. (a -> b) -> a -> b
$ case (((HeadTypeID, HeadID), Ref) -> Bool)
-> [((HeadTypeID, HeadID), Ref)]
-> ([((HeadTypeID, HeadID), Ref)], [((HeadTypeID, HeadID), Ref)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (((HeadTypeID, HeadID) -> (HeadTypeID, HeadID) -> Bool
forall a. Eq a => a -> a -> Bool
==(HeadTypeID
tid, HeadID
hid)) ((HeadTypeID, HeadID) -> Bool)
-> (((HeadTypeID, HeadID), Ref) -> (HeadTypeID, HeadID))
-> ((HeadTypeID, HeadID), Ref)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeadTypeID, HeadID), Ref) -> (HeadTypeID, HeadID)
forall a b. (a, b) -> a
fst) [((HeadTypeID, HeadID), Ref)]
hs of
                     ([] , [((HeadTypeID, HeadID), Ref)]
_  ) -> ([((HeadTypeID, HeadID), Ref)]
hs, Maybe (Head a) -> Either (Maybe (Head a)) (Head a, [Ref -> IO ()])
forall a b. a -> Either a b
Left Maybe (Head a)
forall a. Maybe a
Nothing)
                     (((HeadTypeID, HeadID)
_, Ref
r):[((HeadTypeID, HeadID), Ref)]
_, [((HeadTypeID, HeadID), Ref)]
hs') | Ref
r Ref -> Ref -> Bool
forall a. Eq a => a -> a -> Bool
== Stored' Identity a -> Ref
forall a. Stored a -> Ref
storedRef Stored' Identity a
pobj -> (((HeadTypeID
tid, HeadID
hid), Stored' Identity a -> Ref
forall a. Stored a -> Ref
storedRef Stored' Identity a
stored) ((HeadTypeID, HeadID), Ref)
-> [((HeadTypeID, HeadID), Ref)] -> [((HeadTypeID, HeadID), Ref)]
forall a. a -> [a] -> [a]
: [((HeadTypeID, HeadID), Ref)]
hs',
                                                                  (Head a, [Ref -> IO ()])
-> Either (Maybe (Head a)) (Head a, [Ref -> IO ()])
forall a b. b -> Either a b
Right (HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid Stored' Identity a
stored, [Ref -> IO ()]
ws))
                                     | Bool
otherwise -> ([((HeadTypeID, HeadID), Ref)]
hs, Maybe (Head a) -> Either (Maybe (Head a)) (Head a, [Ref -> IO ()])
forall a b. a -> Either a b
Left (Maybe (Head a)
 -> Either (Maybe (Head a)) (Head a, [Ref -> IO ()]))
-> Maybe (Head a)
-> Either (Maybe (Head a)) (Head a, [Ref -> IO ()])
forall a b. (a -> b) -> a -> b
$ Head a -> Maybe (Head a)
forall a. a -> Maybe a
Just (Head a -> Maybe (Head a)) -> Head a -> Maybe (Head a)
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid (Stored' Identity a -> Head a) -> Stored' Identity a -> Head a
forall a b. (a -> b) -> a -> b
$ Ref -> Stored' Identity a
forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
r)
             case Either (Maybe (Head a)) (Head a, [Ref -> IO ()])
res of
                  Right (Head a
h, [Ref -> IO ()]
ws) -> ((Ref -> IO ()) -> IO ()) -> [Ref -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ref -> IO ()) -> Ref -> IO ()
forall a b. (a -> b) -> a -> b
$ Head a -> Ref
forall a. Head a -> Ref
headRef Head a
h) [Ref -> IO ()]
ws IO ()
-> IO (Either (Maybe (Head a)) (Head a))
-> IO (Either (Maybe (Head a)) (Head a))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Head a -> Either (Maybe (Head a)) (Head a)
forall a b. b -> Either a b
Right Head a
h)
                  Left Maybe (Head a)
x -> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Maybe (Head a)) (Head a)
 -> IO (Either (Maybe (Head a)) (Head a)))
-> Either (Maybe (Head a)) (Head a)
-> IO (Either (Maybe (Head a)) (Head a))
forall a b. (a -> b) -> a -> b
$ Maybe (Head a) -> Either (Maybe (Head a)) (Head a)
forall a b. a -> Either a b
Left Maybe (Head a)
x

updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
updateHead :: forall a (m :: * -> *) b.
(HeadType a, MonadIO m) =>
Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
updateHead Head a
h Stored a -> m (Stored a, b)
f = do
    (Stored a
o, b
x) <- Stored a -> m (Stored a, b)
f (Stored a -> m (Stored a, b)) -> Stored a -> m (Stored a, b)
forall a b. (a -> b) -> a -> b
$ Head a -> Stored a
forall a. Head a -> Stored a
headStoredObject Head a
h
    Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a))
forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a))
replaceHead Head a
h Stored a
o m (Either (Maybe (Head a)) (Head a))
-> (Either (Maybe (Head a)) (Head a) -> m (Maybe (Head a), b))
-> m (Maybe (Head a), b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right Head a
h' -> (Maybe (Head a), b) -> m (Maybe (Head a), b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Head a -> Maybe (Head a)
forall a. a -> Maybe a
Just Head a
h', b
x)
        Left Maybe (Head a)
Nothing -> (Maybe (Head a), b) -> m (Maybe (Head a), b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Head a)
forall a. Maybe a
Nothing, b
x)
        Left (Just Head a
h') -> Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
forall a (m :: * -> *) b.
(HeadType a, MonadIO m) =>
Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
updateHead Head a
h' Stored a -> m (Stored a, b)
f

updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a))
updateHead_ :: forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a))
updateHead_ Head a
h = ((Maybe (Head a), ()) -> Maybe (Head a))
-> m (Maybe (Head a), ()) -> m (Maybe (Head a))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (Head a), ()) -> Maybe (Head a)
forall a b. (a, b) -> a
fst (m (Maybe (Head a), ()) -> m (Maybe (Head a)))
-> ((Stored a -> m (Stored a)) -> m (Maybe (Head a), ()))
-> (Stored a -> m (Stored a))
-> m (Maybe (Head a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Head a -> (Stored a -> m (Stored a, ())) -> m (Maybe (Head a), ())
forall a (m :: * -> *) b.
(HeadType a, MonadIO m) =>
Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b)
updateHead Head a
h ((Stored a -> m (Stored a, ())) -> m (Maybe (Head a), ()))
-> ((Stored a -> m (Stored a)) -> Stored a -> m (Stored a, ()))
-> (Stored a -> m (Stored a))
-> m (Maybe (Head a), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Stored a -> (Stored a, ())) -> m (Stored a) -> m (Stored a, ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,()) (m (Stored a) -> m (Stored a, ()))
-> (Stored a -> m (Stored a)) -> Stored a -> m (Stored a, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)


data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a)

watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead
watchHead :: forall a.
HeadType a =>
Head a -> (Head a -> IO ()) -> IO WatchedHead
watchHead Head a
h = Head a -> (Head a -> Head a) -> (Head a -> IO ()) -> IO WatchedHead
forall a b.
(HeadType a, Eq b) =>
Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead
watchHeadWith Head a
h Head a -> Head a
forall a. a -> a
id

watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead
watchHeadWith :: forall a b.
(HeadType a, Eq b) =>
Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead
watchHeadWith oh :: Head a
oh@(Head HeadID
hid (Stored (Ref Storage
st RefDigest
_) a
_)) Head a -> b
sel b -> IO ()
cb = do
    MVar b
memo <- IO (MVar b)
forall a. IO (MVar a)
newEmptyMVar
    let tid :: HeadTypeID
tid = forall a (proxy :: * -> *). HeadType a => proxy a -> HeadTypeID
headTypeID @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
        addWatcher :: WatchList Identity -> (WatchList Identity, WatchedHead)
addWatcher WatchList Identity
wl = (WatchList Identity
wl', Storage -> WatchID -> MVar b -> WatchedHead
forall a. Storage -> WatchID -> MVar a -> WatchedHead
WatchedHead Storage
st (WatchList Identity -> WatchID
forall (c :: * -> *). WatchList c -> WatchID
wlNext WatchList Identity
wl) MVar b
memo)
            where wl' :: WatchList Identity
wl' = WatchList Identity
wl { wlNext = wlNext wl + 1
                           , wlList = WatchListItem
                               { wlID = wlNext wl
                               , wlHead = (tid, hid)
                               , wlFun = \Ref
r -> do
                                   let x :: b
x = Head a -> b
sel (Head a -> b) -> Head a -> b
forall a b. (a -> b) -> a -> b
$ HeadID -> Stored' Identity a -> Head a
forall (c :: * -> *) a. HeadID -> Stored' c a -> Head' c a
Head HeadID
hid (Stored' Identity a -> Head a) -> Stored' Identity a -> Head a
forall a b. (a -> b) -> a -> b
$ Ref -> Stored' Identity a
forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
r
                                   MVar b -> (b -> IO b) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar b
memo ((b -> IO b) -> IO ()) -> (b -> IO b) -> IO ()
forall a b. (a -> b) -> a -> b
$ \b
prev -> do
                                       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (b
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
prev) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> IO ()
cb b
x
                                       b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x
                               } : wlList wl
                           }

    WatchedHead
watched <- case Storage -> StorageBacking Identity
forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking Storage
st of
         StorageDir { dirPath :: forall (c :: * -> *). StorageBacking c -> String
dirPath = String
spath, dirWatchers :: forall (c :: * -> *).
StorageBacking c -> MVar ([(HeadTypeID, INotify)], WatchList c)
dirWatchers = MVar ([(HeadTypeID, INotify)], WatchList Identity)
mvar } -> MVar ([(HeadTypeID, INotify)], WatchList Identity)
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> IO (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead))
-> IO WatchedHead
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar ([(HeadTypeID, INotify)], WatchList Identity)
mvar ((([(HeadTypeID, INotify)], WatchList Identity)
  -> IO (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead))
 -> IO WatchedHead)
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> IO (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead))
-> IO WatchedHead
forall a b. (a -> b) -> a -> b
$ \([(HeadTypeID, INotify)]
ilist, WatchList Identity
wl) -> do
             [(HeadTypeID, INotify)]
ilist' <- case HeadTypeID -> [(HeadTypeID, INotify)] -> Maybe INotify
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeadTypeID
tid [(HeadTypeID, INotify)]
ilist of
                 Just INotify
_ -> [(HeadTypeID, INotify)] -> IO [(HeadTypeID, INotify)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(HeadTypeID, INotify)]
ilist
                 Maybe INotify
Nothing -> do
                     INotify
inotify <- IO INotify
initINotify
                     IO WatchDescriptor -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO WatchDescriptor -> IO ()) -> IO WatchDescriptor -> IO ()
forall a b. (a -> b) -> a -> b
$ INotify
-> [EventVariety]
-> ByteString
-> (Event -> IO ())
-> IO WatchDescriptor
addWatch INotify
inotify [EventVariety
Move] (String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> HeadTypeID -> String
headTypePath String
spath HeadTypeID
tid) ((Event -> IO ()) -> IO WatchDescriptor)
-> (Event -> IO ()) -> IO WatchDescriptor
forall a b. (a -> b) -> a -> b
$ \case
                         MovedIn { filePath :: Event -> ByteString
filePath = ByteString
fpath } | Just HeadID
ihid <- UUID -> HeadID
HeadID (UUID -> HeadID) -> Maybe UUID -> Maybe HeadID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe UUID
U.fromASCIIBytes ByteString
fpath -> do
                             forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Storage -> HeadID -> m (Maybe (Head a))
loadHead @a Storage
st HeadID
ihid IO (Maybe (Head a)) -> (Maybe (Head a) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                 Just Head a
h -> ((Ref -> IO ()) -> IO ()) -> [Ref -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ref -> IO ()) -> Ref -> IO ()
forall a b. (a -> b) -> a -> b
$ Head a -> Ref
forall a. Head a -> Ref
headRef Head a
h) ([Ref -> IO ()] -> IO ())
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> [Ref -> IO ()])
-> ([(HeadTypeID, INotify)], WatchList Identity)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WatchListItem Identity -> Ref -> IO ())
-> [WatchListItem Identity] -> [Ref -> IO ()]
forall a b. (a -> b) -> [a] -> [b]
map WatchListItem Identity -> Ref -> IO ()
forall (c :: * -> *). WatchListItem c -> Ref' c -> IO ()
wlFun ([WatchListItem Identity] -> [Ref -> IO ()])
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> [WatchListItem Identity])
-> ([(HeadTypeID, INotify)], WatchList Identity)
-> [Ref -> IO ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WatchListItem Identity -> Bool)
-> [WatchListItem Identity] -> [WatchListItem Identity]
forall a. (a -> Bool) -> [a] -> [a]
filter (((HeadTypeID, HeadID) -> (HeadTypeID, HeadID) -> Bool
forall a. Eq a => a -> a -> Bool
== (HeadTypeID
tid, HeadID
ihid)) ((HeadTypeID, HeadID) -> Bool)
-> (WatchListItem Identity -> (HeadTypeID, HeadID))
-> WatchListItem Identity
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WatchListItem Identity -> (HeadTypeID, HeadID)
forall (c :: * -> *). WatchListItem c -> (HeadTypeID, HeadID)
wlHead) ([WatchListItem Identity] -> [WatchListItem Identity])
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> [WatchListItem Identity])
-> ([(HeadTypeID, INotify)], WatchList Identity)
-> [WatchListItem Identity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WatchList Identity -> [WatchListItem Identity]
forall (c :: * -> *). WatchList c -> [WatchListItem c]
wlList (WatchList Identity -> [WatchListItem Identity])
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> WatchList Identity)
-> ([(HeadTypeID, INotify)], WatchList Identity)
-> [WatchListItem Identity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(HeadTypeID, INotify)], WatchList Identity) -> WatchList Identity
forall a b. (a, b) -> b
snd (([(HeadTypeID, INotify)], WatchList Identity) -> IO ())
-> IO ([(HeadTypeID, INotify)], WatchList Identity) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar ([(HeadTypeID, INotify)], WatchList Identity)
-> IO ([(HeadTypeID, INotify)], WatchList Identity)
forall a. MVar a -> IO a
readMVar MVar ([(HeadTypeID, INotify)], WatchList Identity)
mvar
                                 Maybe (Head a)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                         Event
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     [(HeadTypeID, INotify)] -> IO [(HeadTypeID, INotify)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(HeadTypeID, INotify)] -> IO [(HeadTypeID, INotify)])
-> [(HeadTypeID, INotify)] -> IO [(HeadTypeID, INotify)]
forall a b. (a -> b) -> a -> b
$ (HeadTypeID
tid, INotify
inotify) (HeadTypeID, INotify)
-> [(HeadTypeID, INotify)] -> [(HeadTypeID, INotify)]
forall a. a -> [a] -> [a]
: [(HeadTypeID, INotify)]
ilist
             (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead)
-> IO (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((([(HeadTypeID, INotify)], WatchList Identity), WatchedHead)
 -> IO (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead))
-> (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead)
-> IO (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead)
forall a b. (a -> b) -> a -> b
$ (WatchList Identity
 -> ([(HeadTypeID, INotify)], WatchList Identity))
-> (WatchList Identity, WatchedHead)
-> (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([(HeadTypeID, INotify)]
ilist',) ((WatchList Identity, WatchedHead)
 -> (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead))
-> (WatchList Identity, WatchedHead)
-> (([(HeadTypeID, INotify)], WatchList Identity), WatchedHead)
forall a b. (a -> b) -> a -> b
$ WatchList Identity -> (WatchList Identity, WatchedHead)
addWatcher WatchList Identity
wl

         StorageMemory { memWatchers :: forall (c :: * -> *). StorageBacking c -> MVar (WatchList c)
memWatchers = MVar (WatchList Identity)
mvar } -> MVar (WatchList Identity)
-> (WatchList Identity -> IO (WatchList Identity, WatchedHead))
-> IO WatchedHead
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (WatchList Identity)
mvar ((WatchList Identity -> IO (WatchList Identity, WatchedHead))
 -> IO WatchedHead)
-> (WatchList Identity -> IO (WatchList Identity, WatchedHead))
-> IO WatchedHead
forall a b. (a -> b) -> a -> b
$ (WatchList Identity, WatchedHead)
-> IO (WatchList Identity, WatchedHead)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((WatchList Identity, WatchedHead)
 -> IO (WatchList Identity, WatchedHead))
-> (WatchList Identity -> (WatchList Identity, WatchedHead))
-> WatchList Identity
-> IO (WatchList Identity, WatchedHead)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WatchList Identity -> (WatchList Identity, WatchedHead)
addWatcher

    b
cur <- Head a -> b
sel (Head a -> b) -> (Maybe (Head a) -> Head a) -> Maybe (Head a) -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Head a -> (Head a -> Head a) -> Maybe (Head a) -> Head a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Head a
oh Head a -> Head a
forall a. a -> a
id (Maybe (Head a) -> b) -> IO (Maybe (Head a)) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Head a -> IO (Maybe (Head a))
forall a (m :: * -> *).
(HeadType a, MonadIO m) =>
Head a -> m (Maybe (Head a))
reloadHead Head a
oh
    b -> IO ()
cb b
cur
    MVar b -> b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar b
memo b
cur

    WatchedHead -> IO WatchedHead
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return WatchedHead
watched

unwatchHead :: WatchedHead -> IO ()
unwatchHead :: WatchedHead -> IO ()
unwatchHead (WatchedHead Storage
st WatchID
wid MVar a
_) = do
    let delWatcher :: WatchList Identity -> WatchList Identity
delWatcher WatchList Identity
wl = WatchList Identity
wl { wlList = filter ((/=wid) . wlID) $ wlList wl }
    case Storage -> StorageBacking Identity
forall (c :: * -> *). Storage' c -> StorageBacking c
stBacking Storage
st of
        StorageDir { dirWatchers :: forall (c :: * -> *).
StorageBacking c -> MVar ([(HeadTypeID, INotify)], WatchList c)
dirWatchers = MVar ([(HeadTypeID, INotify)], WatchList Identity)
mvar } -> MVar ([(HeadTypeID, INotify)], WatchList Identity)
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> IO ([(HeadTypeID, INotify)], WatchList Identity))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ([(HeadTypeID, INotify)], WatchList Identity)
mvar ((([(HeadTypeID, INotify)], WatchList Identity)
  -> IO ([(HeadTypeID, INotify)], WatchList Identity))
 -> IO ())
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> IO ([(HeadTypeID, INotify)], WatchList Identity))
-> IO ()
forall a b. (a -> b) -> a -> b
$ ([(HeadTypeID, INotify)], WatchList Identity)
-> IO ([(HeadTypeID, INotify)], WatchList Identity)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([(HeadTypeID, INotify)], WatchList Identity)
 -> IO ([(HeadTypeID, INotify)], WatchList Identity))
-> (([(HeadTypeID, INotify)], WatchList Identity)
    -> ([(HeadTypeID, INotify)], WatchList Identity))
-> ([(HeadTypeID, INotify)], WatchList Identity)
-> IO ([(HeadTypeID, INotify)], WatchList Identity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WatchList Identity -> WatchList Identity)
-> ([(HeadTypeID, INotify)], WatchList Identity)
-> ([(HeadTypeID, INotify)], WatchList Identity)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second WatchList Identity -> WatchList Identity
delWatcher
        StorageMemory { memWatchers :: forall (c :: * -> *). StorageBacking c -> MVar (WatchList c)
memWatchers = MVar (WatchList Identity)
mvar } -> MVar (WatchList Identity)
-> (WatchList Identity -> IO (WatchList Identity)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (WatchList Identity)
mvar ((WatchList Identity -> IO (WatchList Identity)) -> IO ())
-> (WatchList Identity -> IO (WatchList Identity)) -> IO ()
forall a b. (a -> b) -> a -> b
$ WatchList Identity -> IO (WatchList Identity)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WatchList Identity -> IO (WatchList Identity))
-> (WatchList Identity -> WatchList Identity)
-> WatchList Identity
-> IO (WatchList Identity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WatchList Identity -> WatchList Identity
delWatcher


class Monad m => MonadStorage m where
    getStorage :: m Storage
    mstore :: Storable a => a -> m (Stored a)

    default mstore :: MonadIO m => Storable a => a -> m (Stored a)
    mstore a
x = do
        Storage
st <- m Storage
forall (m :: * -> *). MonadStorage m => m Storage
getStorage
        Storage -> a -> m (Stored a)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st a
x

instance MonadIO m => MonadStorage (ReaderT Storage m) where
    getStorage :: ReaderT Storage m Storage
getStorage = ReaderT Storage m Storage
forall r (m :: * -> *). MonadReader r m => m r
ask

instance MonadIO m => MonadStorage (ReaderT (Head a) m) where
    getStorage :: ReaderT (Head a) m Storage
getStorage = (Head a -> Storage) -> ReaderT (Head a) m Storage
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Head a -> Storage) -> ReaderT (Head a) m Storage)
-> (Head a -> Storage) -> ReaderT (Head a) m Storage
forall a b. (a -> b) -> a -> b
$ Head a -> Storage
forall a. Head a -> Storage
headStorage


class Storable a where
    store' :: a -> Store
    load' :: Load a

    store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c)
    store Storage' c
st = Storage' c -> Store -> IO (Ref' c)
forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> Store -> IO (Ref' c)
evalStore Storage' c
st (Store -> IO (Ref' c)) -> (a -> Store) -> a -> IO (Ref' c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Store
forall a. Storable a => a -> Store
store'
    load :: Ref -> a
    load = Load a -> Ref -> a
forall a. Load a -> Ref -> a
evalLoad Load a
forall a. Storable a => Load a
load'

class Storable a => ZeroStorable a where
    fromZero :: Storage -> a

data Store = StoreBlob ByteString
           | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]])
           | StoreZero

evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)
evalStore :: forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> Store -> IO (Ref' c)
evalStore Storage' c
st = Storage' c -> Object' c -> IO (Ref' c)
forall (c :: * -> *). Storage' c -> Object' c -> IO (Ref' c)
unsafeStoreObject Storage' c
st (Object' c -> IO (Ref' c))
-> (Store -> IO (Object' c)) -> Store -> IO (Ref' c)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Storage' c -> Store -> IO (Object' c)
forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> Store -> IO (Object' c)
evalStoreObject Storage' c
st

evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)
evalStoreObject :: forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> Store -> IO (Object' c)
evalStoreObject Storage' c
_ (StoreBlob ByteString
x) = Object' c -> IO (Object' c)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Object' c -> IO (Object' c)) -> Object' c -> IO (Object' c)
forall a b. (a -> b) -> a -> b
$ ByteString -> Object' c
forall (c :: * -> *). ByteString -> Object' c
Blob ByteString
x
evalStoreObject Storage' c
s (StoreRec forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> [IO [(ByteString, RecItem' c)]]
f) = [(ByteString, RecItem' c)] -> Object' c
forall (c :: * -> *). [(ByteString, RecItem' c)] -> Object' c
Rec ([(ByteString, RecItem' c)] -> Object' c)
-> ([[(ByteString, RecItem' c)]] -> [(ByteString, RecItem' c)])
-> [[(ByteString, RecItem' c)]]
-> Object' c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(ByteString, RecItem' c)]] -> [(ByteString, RecItem' c)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(ByteString, RecItem' c)]] -> Object' c)
-> IO [[(ByteString, RecItem' c)]] -> IO (Object' c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO [(ByteString, RecItem' c)]] -> IO [[(ByteString, RecItem' c)]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (Storage' c -> [IO [(ByteString, RecItem' c)]]
forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> [IO [(ByteString, RecItem' c)]]
f Storage' c
s)
evalStoreObject Storage' c
_ Store
StoreZero = Object' c -> IO (Object' c)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Object' c
forall (c :: * -> *). Object' c
ZeroObject

newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)
    deriving ((forall a b. (a -> b) -> StoreRecM c a -> StoreRecM c b)
-> (forall a b. a -> StoreRecM c b -> StoreRecM c a)
-> Functor (StoreRecM c)
forall a b. a -> StoreRecM c b -> StoreRecM c a
forall a b. (a -> b) -> StoreRecM c a -> StoreRecM c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (c :: * -> *) a b. a -> StoreRecM c b -> StoreRecM c a
forall (c :: * -> *) a b.
(a -> b) -> StoreRecM c a -> StoreRecM c b
$cfmap :: forall (c :: * -> *) a b.
(a -> b) -> StoreRecM c a -> StoreRecM c b
fmap :: forall a b. (a -> b) -> StoreRecM c a -> StoreRecM c b
$c<$ :: forall (c :: * -> *) a b. a -> StoreRecM c b -> StoreRecM c a
<$ :: forall a b. a -> StoreRecM c b -> StoreRecM c a
Functor, Functor (StoreRecM c)
Functor (StoreRecM c) =>
(forall a. a -> StoreRecM c a)
-> (forall a b.
    StoreRecM c (a -> b) -> StoreRecM c a -> StoreRecM c b)
-> (forall a b c.
    (a -> b -> c) -> StoreRecM c a -> StoreRecM c b -> StoreRecM c c)
-> (forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c b)
-> (forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c a)
-> Applicative (StoreRecM c)
forall a. a -> StoreRecM c a
forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c a
forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c b
forall a b. StoreRecM c (a -> b) -> StoreRecM c a -> StoreRecM c b
forall a b c.
(a -> b -> c) -> StoreRecM c a -> StoreRecM c b -> StoreRecM c c
forall (c :: * -> *). Functor (StoreRecM c)
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (c :: * -> *) a. a -> StoreRecM c a
forall (c :: * -> *) a b.
StoreRecM c a -> StoreRecM c b -> StoreRecM c a
forall (c :: * -> *) a b.
StoreRecM c a -> StoreRecM c b -> StoreRecM c b
forall (c :: * -> *) a b.
StoreRecM c (a -> b) -> StoreRecM c a -> StoreRecM c b
forall (c :: * -> *) a b c.
(a -> b -> c) -> StoreRecM c a -> StoreRecM c b -> StoreRecM c c
$cpure :: forall (c :: * -> *) a. a -> StoreRecM c a
pure :: forall a. a -> StoreRecM c a
$c<*> :: forall (c :: * -> *) a b.
StoreRecM c (a -> b) -> StoreRecM c a -> StoreRecM c b
<*> :: forall a b. StoreRecM c (a -> b) -> StoreRecM c a -> StoreRecM c b
$cliftA2 :: forall (c :: * -> *) a b c.
(a -> b -> c) -> StoreRecM c a -> StoreRecM c b -> StoreRecM c c
liftA2 :: forall a b c.
(a -> b -> c) -> StoreRecM c a -> StoreRecM c b -> StoreRecM c c
$c*> :: forall (c :: * -> *) a b.
StoreRecM c a -> StoreRecM c b -> StoreRecM c b
*> :: forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c b
$c<* :: forall (c :: * -> *) a b.
StoreRecM c a -> StoreRecM c b -> StoreRecM c a
<* :: forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c a
Applicative, Applicative (StoreRecM c)
Applicative (StoreRecM c) =>
(forall a b.
 StoreRecM c a -> (a -> StoreRecM c b) -> StoreRecM c b)
-> (forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c b)
-> (forall a. a -> StoreRecM c a)
-> Monad (StoreRecM c)
forall a. a -> StoreRecM c a
forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c b
forall a b. StoreRecM c a -> (a -> StoreRecM c b) -> StoreRecM c b
forall (c :: * -> *). Applicative (StoreRecM c)
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (c :: * -> *) a. a -> StoreRecM c a
forall (c :: * -> *) a b.
StoreRecM c a -> StoreRecM c b -> StoreRecM c b
forall (c :: * -> *) a b.
StoreRecM c a -> (a -> StoreRecM c b) -> StoreRecM c b
$c>>= :: forall (c :: * -> *) a b.
StoreRecM c a -> (a -> StoreRecM c b) -> StoreRecM c b
>>= :: forall a b. StoreRecM c a -> (a -> StoreRecM c b) -> StoreRecM c b
$c>> :: forall (c :: * -> *) a b.
StoreRecM c a -> StoreRecM c b -> StoreRecM c b
>> :: forall a b. StoreRecM c a -> StoreRecM c b -> StoreRecM c b
$creturn :: forall (c :: * -> *) a. a -> StoreRecM c a
return :: forall a. a -> StoreRecM c a
Monad)

type StoreRec c = StoreRecM c ()

newtype Load a = Load (ReaderT (Ref, Object) (Except String) a)
    deriving ((forall a b. (a -> b) -> Load a -> Load b)
-> (forall a b. a -> Load b -> Load a) -> Functor Load
forall a b. a -> Load b -> Load a
forall a b. (a -> b) -> Load a -> Load b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Load a -> Load b
fmap :: forall a b. (a -> b) -> Load a -> Load b
$c<$ :: forall a b. a -> Load b -> Load a
<$ :: forall a b. a -> Load b -> Load a
Functor, Functor Load
Functor Load =>
(forall a. a -> Load a)
-> (forall a b. Load (a -> b) -> Load a -> Load b)
-> (forall a b c. (a -> b -> c) -> Load a -> Load b -> Load c)
-> (forall a b. Load a -> Load b -> Load b)
-> (forall a b. Load a -> Load b -> Load a)
-> Applicative Load
forall a. a -> Load a
forall a b. Load a -> Load b -> Load a
forall a b. Load a -> Load b -> Load b
forall a b. Load (a -> b) -> Load a -> Load b
forall a b c. (a -> b -> c) -> Load a -> Load b -> Load c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Load a
pure :: forall a. a -> Load a
$c<*> :: forall a b. Load (a -> b) -> Load a -> Load b
<*> :: forall a b. Load (a -> b) -> Load a -> Load b
$cliftA2 :: forall a b c. (a -> b -> c) -> Load a -> Load b -> Load c
liftA2 :: forall a b c. (a -> b -> c) -> Load a -> Load b -> Load c
$c*> :: forall a b. Load a -> Load b -> Load b
*> :: forall a b. Load a -> Load b -> Load b
$c<* :: forall a b. Load a -> Load b -> Load a
<* :: forall a b. Load a -> Load b -> Load a
Applicative, Applicative Load
Applicative Load =>
(forall a. Load a)
-> (forall a. Load a -> Load a -> Load a)
-> (forall a. Load a -> Load [a])
-> (forall a. Load a -> Load [a])
-> Alternative Load
forall a. Load a
forall a. Load a -> Load [a]
forall a. Load a -> Load a -> Load a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall a. Load a
empty :: forall a. Load a
$c<|> :: forall a. Load a -> Load a -> Load a
<|> :: forall a. Load a -> Load a -> Load a
$csome :: forall a. Load a -> Load [a]
some :: forall a. Load a -> Load [a]
$cmany :: forall a. Load a -> Load [a]
many :: forall a. Load a -> Load [a]
Alternative, Applicative Load
Applicative Load =>
(forall a b. Load a -> (a -> Load b) -> Load b)
-> (forall a b. Load a -> Load b -> Load b)
-> (forall a. a -> Load a)
-> Monad Load
forall a. a -> Load a
forall a b. Load a -> Load b -> Load b
forall a b. Load a -> (a -> Load b) -> Load b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Load a -> (a -> Load b) -> Load b
>>= :: forall a b. Load a -> (a -> Load b) -> Load b
$c>> :: forall a b. Load a -> Load b -> Load b
>> :: forall a b. Load a -> Load b -> Load b
$creturn :: forall a. a -> Load a
return :: forall a. a -> Load a
Monad, Monad Load
Alternative Load
(Alternative Load, Monad Load) =>
(forall a. Load a)
-> (forall a. Load a -> Load a -> Load a) -> MonadPlus Load
forall a. Load a
forall a. Load a -> Load a -> Load a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
$cmzero :: forall a. Load a
mzero :: forall a. Load a
$cmplus :: forall a. Load a -> Load a -> Load a
mplus :: forall a. Load a -> Load a -> Load a
MonadPlus, MonadError String)

evalLoad :: Load a -> Ref -> a
evalLoad :: forall a. Load a -> Ref -> a
evalLoad (Load ReaderT (Ref, Object) (Except String) a
f) Ref
ref = (String -> a) -> (a -> a) -> Either String a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error {- TODO throw -} (String -> a) -> (String -> String) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString -> String
BC.unpack (Ref -> ByteString
forall (c :: * -> *). Ref' c -> ByteString
showRef Ref
ref) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": ")String -> String -> String
forall a. [a] -> [a] -> [a]
++)) a -> a
forall a. a -> a
id (Either String a -> a) -> Either String a -> a
forall a b. (a -> b) -> a -> b
$ Except String a -> Either String a
forall e a. Except e a -> Either e a
runExcept (Except String a -> Either String a)
-> Except String a -> Either String a
forall a b. (a -> b) -> a -> b
$ ReaderT (Ref, Object) (Except String) a
-> (Ref, Object) -> Except String a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Ref, Object) (Except String) a
f (Ref
ref, Ref -> LoadResult Identity Object
forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> LoadResult c (Object' c)
lazyLoadObject Ref
ref)

loadCurrentRef :: Load Ref
loadCurrentRef :: Load Ref
loadCurrentRef = ReaderT (Ref, Object) (Except String) Ref -> Load Ref
forall a. ReaderT (Ref, Object) (Except String) a -> Load a
Load (ReaderT (Ref, Object) (Except String) Ref -> Load Ref)
-> ReaderT (Ref, Object) (Except String) Ref -> Load Ref
forall a b. (a -> b) -> a -> b
$ ((Ref, Object) -> Ref) -> ReaderT (Ref, Object) (Except String) Ref
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Ref, Object) -> Ref
forall a b. (a, b) -> a
fst

loadCurrentObject :: Load Object
loadCurrentObject :: Load Object
loadCurrentObject = ReaderT (Ref, Object) (Except String) Object -> Load Object
forall a. ReaderT (Ref, Object) (Except String) a -> Load a
Load (ReaderT (Ref, Object) (Except String) Object -> Load Object)
-> ReaderT (Ref, Object) (Except String) Object -> Load Object
forall a b. (a -> b) -> a -> b
$ ((Ref, Object) -> Object)
-> ReaderT (Ref, Object) (Except String) Object
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Ref, Object) -> Object
forall a b. (a, b) -> b
snd

newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a)
    deriving ((forall a b. (a -> b) -> LoadRec a -> LoadRec b)
-> (forall a b. a -> LoadRec b -> LoadRec a) -> Functor LoadRec
forall a b. a -> LoadRec b -> LoadRec a
forall a b. (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LoadRec a -> LoadRec b
fmap :: forall a b. (a -> b) -> LoadRec a -> LoadRec b
$c<$ :: forall a b. a -> LoadRec b -> LoadRec a
<$ :: forall a b. a -> LoadRec b -> LoadRec a
Functor, Functor LoadRec
Functor LoadRec =>
(forall a. a -> LoadRec a)
-> (forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b)
-> (forall a b c.
    (a -> b -> c) -> LoadRec a -> LoadRec b -> LoadRec c)
-> (forall a b. LoadRec a -> LoadRec b -> LoadRec b)
-> (forall a b. LoadRec a -> LoadRec b -> LoadRec a)
-> Applicative LoadRec
forall a. a -> LoadRec a
forall a b. LoadRec a -> LoadRec b -> LoadRec a
forall a b. LoadRec a -> LoadRec b -> LoadRec b
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall a b c. (a -> b -> c) -> LoadRec a -> LoadRec b -> LoadRec c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> LoadRec a
pure :: forall a. a -> LoadRec a
$c<*> :: forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
<*> :: forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
$cliftA2 :: forall a b c. (a -> b -> c) -> LoadRec a -> LoadRec b -> LoadRec c
liftA2 :: forall a b c. (a -> b -> c) -> LoadRec a -> LoadRec b -> LoadRec c
$c*> :: forall a b. LoadRec a -> LoadRec b -> LoadRec b
*> :: forall a b. LoadRec a -> LoadRec b -> LoadRec b
$c<* :: forall a b. LoadRec a -> LoadRec b -> LoadRec a
<* :: forall a b. LoadRec a -> LoadRec b -> LoadRec a
Applicative, Applicative LoadRec
Applicative LoadRec =>
(forall a. LoadRec a)
-> (forall a. LoadRec a -> LoadRec a -> LoadRec a)
-> (forall a. LoadRec a -> LoadRec [a])
-> (forall a. LoadRec a -> LoadRec [a])
-> Alternative LoadRec
forall a. LoadRec a
forall a. LoadRec a -> LoadRec [a]
forall a. LoadRec a -> LoadRec a -> LoadRec a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall a. LoadRec a
empty :: forall a. LoadRec a
$c<|> :: forall a. LoadRec a -> LoadRec a -> LoadRec a
<|> :: forall a. LoadRec a -> LoadRec a -> LoadRec a
$csome :: forall a. LoadRec a -> LoadRec [a]
some :: forall a. LoadRec a -> LoadRec [a]
$cmany :: forall a. LoadRec a -> LoadRec [a]
many :: forall a. LoadRec a -> LoadRec [a]
Alternative, Applicative LoadRec
Applicative LoadRec =>
(forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b)
-> (forall a b. LoadRec a -> LoadRec b -> LoadRec b)
-> (forall a. a -> LoadRec a)
-> Monad LoadRec
forall a. a -> LoadRec a
forall a b. LoadRec a -> LoadRec b -> LoadRec b
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
>>= :: forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
$c>> :: forall a b. LoadRec a -> LoadRec b -> LoadRec b
>> :: forall a b. LoadRec a -> LoadRec b -> LoadRec b
$creturn :: forall a. a -> LoadRec a
return :: forall a. a -> LoadRec a
Monad, Monad LoadRec
Alternative LoadRec
(Alternative LoadRec, Monad LoadRec) =>
(forall a. LoadRec a)
-> (forall a. LoadRec a -> LoadRec a -> LoadRec a)
-> MonadPlus LoadRec
forall a. LoadRec a
forall a. LoadRec a -> LoadRec a -> LoadRec a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
$cmzero :: forall a. LoadRec a
mzero :: forall a. LoadRec a
$cmplus :: forall a. LoadRec a -> LoadRec a -> LoadRec a
mplus :: forall a. LoadRec a -> LoadRec a -> LoadRec a
MonadPlus, MonadError String)

loadRecCurrentRef :: LoadRec Ref
loadRecCurrentRef :: LoadRec Ref
loadRecCurrentRef = ReaderT (Ref, [(ByteString, RecItem)]) (Except String) Ref
-> LoadRec Ref
forall a.
ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a
-> LoadRec a
LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) Ref
 -> LoadRec Ref)
-> ReaderT (Ref, [(ByteString, RecItem)]) (Except String) Ref
-> LoadRec Ref
forall a b. (a -> b) -> a -> b
$ ((Ref, [(ByteString, RecItem)]) -> Ref)
-> ReaderT (Ref, [(ByteString, RecItem)]) (Except String) Ref
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Ref, [(ByteString, RecItem)]) -> Ref
forall a b. (a, b) -> a
fst

loadRecItems :: LoadRec [(ByteString, RecItem)]
loadRecItems :: LoadRec [(ByteString, RecItem)]
loadRecItems = ReaderT
  (Ref, [(ByteString, RecItem)])
  (Except String)
  [(ByteString, RecItem)]
-> LoadRec [(ByteString, RecItem)]
forall a.
ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a
-> LoadRec a
LoadRec (ReaderT
   (Ref, [(ByteString, RecItem)])
   (Except String)
   [(ByteString, RecItem)]
 -> LoadRec [(ByteString, RecItem)])
-> ReaderT
     (Ref, [(ByteString, RecItem)])
     (Except String)
     [(ByteString, RecItem)]
-> LoadRec [(ByteString, RecItem)]
forall a b. (a -> b) -> a -> b
$ ((Ref, [(ByteString, RecItem)]) -> [(ByteString, RecItem)])
-> ReaderT
     (Ref, [(ByteString, RecItem)])
     (Except String)
     [(ByteString, RecItem)]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Ref, [(ByteString, RecItem)]) -> [(ByteString, RecItem)]
forall a b. (a, b) -> b
snd


instance Storable Object where
    store' :: Object -> Store
store' (Blob ByteString
bs) = ByteString -> Store
StoreBlob ByteString
bs
    store' (Rec [(ByteString, RecItem)]
xs) = (forall (c :: * -> *).
 StorageCompleteness c =>
 Storage' c -> [IO [(ByteString, RecItem' c)]])
-> Store
StoreRec ((forall (c :: * -> *).
  StorageCompleteness c =>
  Storage' c -> [IO [(ByteString, RecItem' c)]])
 -> Store)
-> (forall (c :: * -> *).
    StorageCompleteness c =>
    Storage' c -> [IO [(ByteString, RecItem' c)]])
-> Store
forall a b. (a -> b) -> a -> b
$ \Storage' c
st -> IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]])
-> IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]]
forall a b. (a -> b) -> a -> b
$ do
        Rec [(ByteString, RecItem' c)]
xs' <- Storage' c -> Object -> IO (LoadResult Identity (Object' c))
forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
copyObject Storage' c
st ([(ByteString, RecItem)] -> Object
forall (c :: * -> *). [(ByteString, RecItem' c)] -> Object' c
Rec [(ByteString, RecItem)]
xs)
        [(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(ByteString, RecItem' c)]
xs'
    store' Object
ZeroObject = Store
StoreZero

    load' :: Load Object
load' = Load Object
loadCurrentObject

    store :: forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> Object -> IO (Ref' c)
store Storage' c
st = Storage' c -> Object' c -> IO (Ref' c)
forall (c :: * -> *). Storage' c -> Object' c -> IO (Ref' c)
unsafeStoreObject Storage' c
st (Object' c -> IO (Ref' c))
-> (Object -> IO (Object' c)) -> Object -> IO (Ref' c)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Storage' c -> Object -> IO (LoadResult Identity (Object' c))
forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
copyObject Storage' c
st
    load :: Ref -> Object
load = Ref -> LoadResult Identity Object
Ref -> Object
forall (c :: * -> *).
StorageCompleteness c =>
Ref' c -> LoadResult c (Object' c)
lazyLoadObject

instance Storable ByteString where
    store' :: ByteString -> Store
store' = ByteString -> Store
storeBlob
    load' :: Load ByteString
load' = (ByteString -> ByteString) -> Load ByteString
forall a. (ByteString -> a) -> Load a
loadBlob ByteString -> ByteString
forall a. a -> a
id

instance Storable a => Storable [a] where
    store' :: [a] -> Store
store' []     = Store
storeZero
    store' (a
x:[a]
xs) = (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c)
 -> Store)
-> (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
forall a b. (a -> b) -> a -> b
$ do
        String -> a -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"i" a
x
        String -> [a] -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"n" [a]
xs

    load' :: Load [a]
load' = Load Object
loadCurrentObject Load Object -> (Object -> Load [a]) -> Load [a]
forall a b. Load a -> (a -> Load b) -> Load b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Object
ZeroObject -> [a] -> Load [a]
forall a. a -> Load a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                Object
_          -> LoadRec [a] -> Load [a]
forall a. LoadRec a -> Load a
loadRec (LoadRec [a] -> Load [a]) -> LoadRec [a] -> Load [a]
forall a b. (a -> b) -> a -> b
$ (:)
                                  (a -> [a] -> [a]) -> LoadRec a -> LoadRec ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec a
forall a. Storable a => String -> LoadRec a
loadRef String
"i"
                                  LoadRec ([a] -> [a]) -> LoadRec [a] -> LoadRec [a]
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec [a]
forall a. Storable a => String -> LoadRec a
loadRef String
"n"

instance Storable a => ZeroStorable [a] where
    fromZero :: Storage -> [a]
fromZero Storage
_ = []


storeBlob :: ByteString -> Store
storeBlob :: ByteString -> Store
storeBlob = ByteString -> Store
StoreBlob

storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store
storeRec :: (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
storeRec forall (c :: * -> *). StorageCompleteness c => StoreRec c
sr = (forall (c :: * -> *).
 StorageCompleteness c =>
 Storage' c -> [IO [(ByteString, RecItem' c)]])
-> Store
StoreRec ((forall (c :: * -> *).
  StorageCompleteness c =>
  Storage' c -> [IO [(ByteString, RecItem' c)]])
 -> Store)
-> (forall (c :: * -> *).
    StorageCompleteness c =>
    Storage' c -> [IO [(ByteString, RecItem' c)]])
-> Store
forall a b. (a -> b) -> a -> b
$ do
    let StoreRecM ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
r = StoreRecM c ()
forall (c :: * -> *). StorageCompleteness c => StoreRec c
sr
    Writer [IO [(ByteString, RecItem' c)]] ()
-> [IO [(ByteString, RecItem' c)]]
forall w a. Writer w a -> w
execWriter (Writer [IO [(ByteString, RecItem' c)]] ()
 -> [IO [(ByteString, RecItem' c)]])
-> (Storage' c -> Writer [IO [(ByteString, RecItem' c)]] ())
-> Storage' c
-> [IO [(ByteString, RecItem' c)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> Storage' c -> Writer [IO [(ByteString, RecItem' c)]] ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
r

storeZero :: Store
storeZero :: Store
storeZero = Store
StoreZero


class StorableText a where
    toText :: a -> Text
    fromText :: MonadError String m => Text -> m a

instance StorableText Text where
    toText :: Text -> Text
toText = Text -> Text
forall a. a -> a
id; fromText :: forall (m :: * -> *). MonadError String m => Text -> m Text
fromText = Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance StorableText [Char] where
    toText :: String -> Text
toText = String -> Text
T.pack; fromText :: forall (m :: * -> *). MonadError String m => Text -> m String
fromText = String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> (Text -> String) -> Text -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack


class StorableDate a where
    toDate :: a -> ZonedTime
    fromDate :: ZonedTime -> a

instance StorableDate ZonedTime where
    toDate :: ZonedTime -> ZonedTime
toDate = ZonedTime -> ZonedTime
forall a. a -> a
id; fromDate :: ZonedTime -> ZonedTime
fromDate = ZonedTime -> ZonedTime
forall a. a -> a
id

instance StorableDate UTCTime where
    toDate :: UTCTime -> ZonedTime
toDate = TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
utc
    fromDate :: ZonedTime -> UTCTime
fromDate = ZonedTime -> UTCTime
zonedTimeToUTC

instance StorableDate Day where
    toDate :: Day -> ZonedTime
toDate Day
day = UTCTime -> ZonedTime
forall a. StorableDate a => a -> ZonedTime
toDate (UTCTime -> ZonedTime) -> UTCTime -> ZonedTime
forall a b. (a -> b) -> a -> b
$ Day -> DiffTime -> UTCTime
UTCTime Day
day DiffTime
0
    fromDate :: ZonedTime -> Day
fromDate = UTCTime -> Day
utctDay (UTCTime -> Day) -> (ZonedTime -> UTCTime) -> ZonedTime -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> UTCTime
forall a. StorableDate a => ZonedTime -> a
fromDate


class StorableUUID a where
    toUUID :: a -> UUID
    fromUUID :: UUID -> a

instance StorableUUID UUID where
    toUUID :: UUID -> UUID
toUUID = UUID -> UUID
forall a. a -> a
id; fromUUID :: UUID -> UUID
fromUUID = UUID -> UUID
forall a. a -> a
id


storeEmpty :: String -> StoreRec c
storeEmpty :: forall (c :: * -> *). String -> StoreRec c
storeEmpty String
name = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, RecItem' c
forall (c :: * -> *). RecItem' c
RecEmpty)]]

storeMbEmpty :: String -> Maybe () -> StoreRec c
storeMbEmpty :: forall (c :: * -> *). String -> Maybe () -> StoreRec c
storeMbEmpty String
name = StoreRec c -> (() -> StoreRec c) -> Maybe () -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (StoreRec c -> () -> StoreRec c
forall a b. a -> b -> a
const (StoreRec c -> () -> StoreRec c) -> StoreRec c -> () -> StoreRec c
forall a b. (a -> b) -> a -> b
$ String -> StoreRec c
forall (c :: * -> *). String -> StoreRec c
storeEmpty String
name)

storeInt :: Integral a => String -> a -> StoreRec c
storeInt :: forall a (c :: * -> *). Integral a => String -> a -> StoreRec c
storeInt String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, Integer -> RecItem' c
forall (c :: * -> *). Integer -> RecItem' c
RecInt (Integer -> RecItem' c) -> Integer -> RecItem' c
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a. Integral a => a -> Integer
toInteger a
x)]]

storeMbInt :: Integral a => String -> Maybe a -> StoreRec c
storeMbInt :: forall a (c :: * -> *).
Integral a =>
String -> Maybe a -> StoreRec c
storeMbInt String
name = StoreRec c -> (a -> StoreRec c) -> Maybe a -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> a -> StoreRec c
forall a (c :: * -> *). Integral a => String -> a -> StoreRec c
storeInt String
name)

storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c
storeNum :: forall a (c :: * -> *).
(Real a, Fractional a) =>
String -> a -> StoreRec c
storeNum String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, Rational -> RecItem' c
forall (c :: * -> *). Rational -> RecItem' c
RecNum (Rational -> RecItem' c) -> Rational -> RecItem' c
forall a b. (a -> b) -> a -> b
$ a -> Rational
forall a. Real a => a -> Rational
toRational a
x)]]

storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c
storeMbNum :: forall a (c :: * -> *).
(Real a, Fractional a) =>
String -> Maybe a -> StoreRec c
storeMbNum String
name = StoreRec c -> (a -> StoreRec c) -> Maybe a -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> a -> StoreRec c
forall a (c :: * -> *).
(Real a, Fractional a) =>
String -> a -> StoreRec c
storeNum String
name)

storeText :: StorableText a => String -> a -> StoreRec c
storeText :: forall a (c :: * -> *). StorableText a => String -> a -> StoreRec c
storeText String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, Text -> RecItem' c
forall (c :: * -> *). Text -> RecItem' c
RecText (Text -> RecItem' c) -> Text -> RecItem' c
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. StorableText a => a -> Text
toText a
x)]]

storeMbText :: StorableText a => String -> Maybe a -> StoreRec c
storeMbText :: forall a (c :: * -> *).
StorableText a =>
String -> Maybe a -> StoreRec c
storeMbText String
name = StoreRec c -> (a -> StoreRec c) -> Maybe a -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> a -> StoreRec c
forall a (c :: * -> *). StorableText a => String -> a -> StoreRec c
storeText String
name)

storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c
storeBinary :: forall a (c :: * -> *).
ByteArrayAccess a =>
String -> a -> StoreRec c
storeBinary String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, ByteString -> RecItem' c
forall (c :: * -> *). ByteString -> RecItem' c
RecBinary (ByteString -> RecItem' c) -> ByteString -> RecItem' c
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert a
x)]]

storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c
storeMbBinary :: forall a (c :: * -> *).
ByteArrayAccess a =>
String -> Maybe a -> StoreRec c
storeMbBinary String
name = StoreRec c -> (a -> StoreRec c) -> Maybe a -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> a -> StoreRec c
forall a (c :: * -> *).
ByteArrayAccess a =>
String -> a -> StoreRec c
storeBinary String
name)

storeDate :: StorableDate a => String -> a -> StoreRec c
storeDate :: forall a (c :: * -> *). StorableDate a => String -> a -> StoreRec c
storeDate String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, ZonedTime -> RecItem' c
forall (c :: * -> *). ZonedTime -> RecItem' c
RecDate (ZonedTime -> RecItem' c) -> ZonedTime -> RecItem' c
forall a b. (a -> b) -> a -> b
$ a -> ZonedTime
forall a. StorableDate a => a -> ZonedTime
toDate a
x)]]

storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c
storeMbDate :: forall a (c :: * -> *).
StorableDate a =>
String -> Maybe a -> StoreRec c
storeMbDate String
name = StoreRec c -> (a -> StoreRec c) -> Maybe a -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> a -> StoreRec c
forall a (c :: * -> *). StorableDate a => String -> a -> StoreRec c
storeDate String
name)

storeUUID :: StorableUUID a => String -> a -> StoreRec c
storeUUID :: forall a (c :: * -> *). StorableUUID a => String -> a -> StoreRec c
storeUUID String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [[(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, UUID -> RecItem' c
forall (c :: * -> *). UUID -> RecItem' c
RecUUID (UUID -> RecItem' c) -> UUID -> RecItem' c
forall a b. (a -> b) -> a -> b
$ a -> UUID
forall a. StorableUUID a => a -> UUID
toUUID a
x)]]

storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c
storeMbUUID :: forall a (c :: * -> *).
StorableUUID a =>
String -> Maybe a -> StoreRec c
storeMbUUID String
name = StoreRec c -> (a -> StoreRec c) -> Maybe a -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> a -> StoreRec c
forall a (c :: * -> *). StorableUUID a => String -> a -> StoreRec c
storeUUID String
name)

storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
storeRef :: forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ do
    Storage' c
s <- ReaderT
  (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) (Storage' c)
forall r (m :: * -> *). MonadReader r m => m r
ask
    [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([IO [(ByteString, RecItem' c)]]
 -> ReaderT
      (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ())
-> [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall a b. (a -> b) -> a -> b
$ (IO [(ByteString, RecItem' c)]
-> [IO [(ByteString, RecItem' c)]]
-> [IO [(ByteString, RecItem' c)]]
forall a. a -> [a] -> [a]
:[]) (IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]])
-> IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]]
forall a b. (a -> b) -> a -> b
$ do
        Ref' c
ref <- Storage' c -> a -> IO (Ref' c)
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
Storage' c -> a -> IO (Ref' c)
forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> a -> IO (Ref' c)
store Storage' c
s a
x
        [(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, Ref' c -> RecItem' c
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef Ref' c
ref)]

storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c
storeMbRef :: forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> Maybe a -> StoreRec c
storeMbRef String
name = StoreRec c -> (a -> StoreRec c) -> Maybe a -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> a -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
name)

storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c
storeRawRef :: forall (c :: * -> *).
StorageCompleteness c =>
String -> Ref -> StoreRec c
storeRawRef String
name Ref
ref = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ do
    Storage' c
st <- ReaderT
  (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) (Storage' c)
forall r (m :: * -> *). MonadReader r m => m r
ask
    [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([IO [(ByteString, RecItem' c)]]
 -> ReaderT
      (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ())
-> [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall a b. (a -> b) -> a -> b
$ (IO [(ByteString, RecItem' c)]
-> [IO [(ByteString, RecItem' c)]]
-> [IO [(ByteString, RecItem' c)]]
forall a. a -> [a] -> [a]
:[]) (IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]])
-> IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]]
forall a b. (a -> b) -> a -> b
$ do
        Ref' c
ref' <- Storage' c -> Ref -> IO (LoadResult Identity (Ref' c))
forall (c :: * -> *) (c' :: * -> *) (m :: * -> *).
(StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
copyRef Storage' c
st Ref
ref
        [(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String -> ByteString
BC.pack String
name, Ref' c -> RecItem' c
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef Ref' c
ref')]

storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c
storeMbRawRef :: forall (c :: * -> *).
StorageCompleteness c =>
String -> Maybe Ref -> StoreRec c
storeMbRawRef String
name = StoreRec c -> (Ref -> StoreRec c) -> Maybe Ref -> StoreRec c
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StoreRec c
forall a. a -> StoreRecM c a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> Ref -> StoreRec c
forall (c :: * -> *).
StorageCompleteness c =>
String -> Ref -> StoreRec c
storeRawRef String
name)

storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
storeZRef :: forall a (c :: * -> *).
(ZeroStorable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeZRef String
name a
x = ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall (c :: * -> *) a.
ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a
-> StoreRecM c a
StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
 -> StoreRecM c ())
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
-> StoreRecM c ()
forall a b. (a -> b) -> a -> b
$ do
    Storage' c
s <- ReaderT
  (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) (Storage' c)
forall r (m :: * -> *). MonadReader r m => m r
ask
    [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([IO [(ByteString, RecItem' c)]]
 -> ReaderT
      (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ())
-> [IO [(ByteString, RecItem' c)]]
-> ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) ()
forall a b. (a -> b) -> a -> b
$ (IO [(ByteString, RecItem' c)]
-> [IO [(ByteString, RecItem' c)]]
-> [IO [(ByteString, RecItem' c)]]
forall a. a -> [a] -> [a]
:[]) (IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]])
-> IO [(ByteString, RecItem' c)] -> [IO [(ByteString, RecItem' c)]]
forall a b. (a -> b) -> a -> b
$ do
        Ref' c
ref <- Storage' c -> a -> IO (Ref' c)
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
Storage' c -> a -> IO (Ref' c)
forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> a -> IO (Ref' c)
store Storage' c
s a
x
        [(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)])
-> [(ByteString, RecItem' c)] -> IO [(ByteString, RecItem' c)]
forall a b. (a -> b) -> a -> b
$ if Ref' c -> Bool
forall (c :: * -> *). Ref' c -> Bool
isZeroRef Ref' c
ref then []
                                  else [(String -> ByteString
BC.pack String
name, Ref' c -> RecItem' c
forall (c :: * -> *). Ref' c -> RecItem' c
RecRef Ref' c
ref)]


loadBlob :: (ByteString -> a) -> Load a
loadBlob :: forall a. (ByteString -> a) -> Load a
loadBlob ByteString -> a
f = Load Object
loadCurrentObject Load Object -> (Object -> Load a) -> Load a
forall a b. Load a -> (a -> Load b) -> Load b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Blob ByteString
x -> a -> Load a
forall a. a -> Load a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Load a) -> a -> Load a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
f ByteString
x
    Object
_      -> String -> Load a
forall a. String -> Load a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expecting blob"

loadRec :: LoadRec a -> Load a
loadRec :: forall a. LoadRec a -> Load a
loadRec (LoadRec ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a
lrec) = Load Object
loadCurrentObject Load Object -> (Object -> Load a) -> Load a
forall a b. Load a -> (a -> Load b) -> Load b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Rec [(ByteString, RecItem)]
rs -> do
        Ref
ref <- Load Ref
loadCurrentRef
        (String -> Load a) -> (a -> Load a) -> Either String a -> Load a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Load a
forall a. String -> Load a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> Load a
forall a. a -> Load a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a -> Load a) -> Either String a -> Load a
forall a b. (a -> b) -> a -> b
$ Except String a -> Either String a
forall e a. Except e a -> Either e a
runExcept (Except String a -> Either String a)
-> Except String a -> Either String a
forall a b. (a -> b) -> a -> b
$ ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a
-> (Ref, [(ByteString, RecItem)]) -> Except String a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a
lrec (Ref
ref, [(ByteString, RecItem)]
rs)
    Object
_ -> String -> Load a
forall a. String -> Load a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expecting record"

loadZero :: a -> Load a
loadZero :: forall a. a -> Load a
loadZero a
x = Load Object
loadCurrentObject Load Object -> (Object -> Load a) -> Load a
forall a b. Load a -> (a -> Load b) -> Load b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Object
ZeroObject -> a -> Load a
forall a. a -> Load a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    Object
_          -> String -> Load a
forall a. String -> Load a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Expecting zero"


loadEmpty :: String -> LoadRec ()
loadEmpty :: String -> LoadRec ()
loadEmpty String
name = LoadRec () -> (() -> LoadRec ()) -> Maybe () -> LoadRec ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec ()
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec ()) -> String -> LoadRec ()
forall a b. (a -> b) -> a -> b
$ String
"Missing record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") () -> LoadRec ()
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe () -> LoadRec ()) -> LoadRec (Maybe ()) -> LoadRec ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe ())
loadMbEmpty String
name

loadMbEmpty :: String -> LoadRec (Maybe ())
loadMbEmpty :: String -> LoadRec (Maybe ())
loadMbEmpty String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe ())) -> LoadRec (Maybe ())
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe () -> LoadRec (Maybe ())
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing
    Just (RecItem
RecEmpty) -> Maybe () -> LoadRec (Maybe ())
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Maybe ()
forall a. a -> Maybe a
Just ())
    Just RecItem
_ -> String -> LoadRec (Maybe ())
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe ())) -> String -> LoadRec (Maybe ())
forall a b. (a -> b) -> a -> b
$ String
"Expecting type int of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadInt :: Num a => String -> LoadRec a
loadInt :: forall a. Num a => String -> LoadRec a
loadInt String
name = LoadRec a -> (a -> LoadRec a) -> Maybe a -> LoadRec a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Missing record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec a) -> LoadRec (Maybe a) -> LoadRec a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe a)
forall a. Num a => String -> LoadRec (Maybe a)
loadMbInt String
name

loadMbInt :: Num a => String -> LoadRec (Maybe a)
loadMbInt :: forall a. Num a => String -> LoadRec (Maybe a)
loadMbInt String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe a)) -> LoadRec (Maybe a)
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just (RecInt Integer
x) -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
x)
    Just RecItem
_ -> String -> LoadRec (Maybe a)
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe a)) -> String -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"Expecting type int of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadNum :: (Real a, Fractional a) => String -> LoadRec a
loadNum :: forall a. (Real a, Fractional a) => String -> LoadRec a
loadNum String
name = LoadRec a -> (a -> LoadRec a) -> Maybe a -> LoadRec a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Missing record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec a) -> LoadRec (Maybe a) -> LoadRec a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe a)
forall a. (Real a, Fractional a) => String -> LoadRec (Maybe a)
loadMbNum String
name

loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a)
loadMbNum :: forall a. (Real a, Fractional a) => String -> LoadRec (Maybe a)
loadMbNum String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe a)) -> LoadRec (Maybe a)
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just (RecNum Rational
x) -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Rational -> a
forall a. Fractional a => Rational -> a
fromRational Rational
x)
    Just RecItem
_ -> String -> LoadRec (Maybe a)
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe a)) -> String -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"Expecting type number of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadText :: StorableText a => String -> LoadRec a
loadText :: forall a. StorableText a => String -> LoadRec a
loadText String
name = LoadRec a -> (a -> LoadRec a) -> Maybe a -> LoadRec a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Missing record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec a) -> LoadRec (Maybe a) -> LoadRec a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe a)
forall a. StorableText a => String -> LoadRec (Maybe a)
loadMbText String
name

loadMbText :: StorableText a => String -> LoadRec (Maybe a)
loadMbText :: forall a. StorableText a => String -> LoadRec (Maybe a)
loadMbText String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe a)) -> LoadRec (Maybe a)
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just (RecText Text
x) -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> LoadRec a -> LoadRec (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> LoadRec a
forall a (m :: * -> *).
(StorableText a, MonadError String m) =>
Text -> m a
forall (m :: * -> *). MonadError String m => Text -> m a
fromText Text
x
    Just RecItem
_ -> String -> LoadRec (Maybe a)
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe a)) -> String -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"Expecting type text of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadTexts :: StorableText a => String -> LoadRec [a]
loadTexts :: forall a. StorableText a => String -> LoadRec [a]
loadTexts String
name = do
    [RecItem]
items <- ((ByteString, RecItem) -> RecItem)
-> [(ByteString, RecItem)] -> [RecItem]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, RecItem) -> RecItem
forall a b. (a, b) -> b
snd ([(ByteString, RecItem)] -> [RecItem])
-> ([(ByteString, RecItem)] -> [(ByteString, RecItem)])
-> [(ByteString, RecItem)]
-> [RecItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, RecItem) -> Bool)
-> [(ByteString, RecItem)] -> [(ByteString, RecItem)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> ByteString
BC.pack String
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool)
-> ((ByteString, RecItem) -> ByteString)
-> (ByteString, RecItem)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, RecItem) -> ByteString
forall a b. (a, b) -> a
fst) ([(ByteString, RecItem)] -> [RecItem])
-> LoadRec [(ByteString, RecItem)] -> LoadRec [RecItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems
    [RecItem] -> (RecItem -> LoadRec a) -> LoadRec [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RecItem]
items ((RecItem -> LoadRec a) -> LoadRec [a])
-> (RecItem -> LoadRec a) -> LoadRec [a]
forall a b. (a -> b) -> a -> b
$ \case RecText Text
x -> Text -> LoadRec a
forall a (m :: * -> *).
(StorableText a, MonadError String m) =>
Text -> m a
forall (m :: * -> *). MonadError String m => Text -> m a
fromText Text
x
                       RecItem
_ -> String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Expecting type text of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadBinary :: BA.ByteArray a => String -> LoadRec a
loadBinary :: forall a. ByteArray a => String -> LoadRec a
loadBinary String
name = LoadRec a -> (a -> LoadRec a) -> Maybe a -> LoadRec a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Missing record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec a) -> LoadRec (Maybe a) -> LoadRec a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe a)
forall a. ByteArray a => String -> LoadRec (Maybe a)
loadMbBinary String
name

loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a)
loadMbBinary :: forall a. ByteArray a => String -> LoadRec (Maybe a)
loadMbBinary String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe a)) -> LoadRec (Maybe a)
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just (RecBinary ByteString
x) -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec (Maybe a)) -> Maybe a -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
x
    Just RecItem
_ -> String -> LoadRec (Maybe a)
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe a)) -> String -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"Expecting type binary of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadBinaries :: BA.ByteArray a => String -> LoadRec [a]
loadBinaries :: forall a. ByteArray a => String -> LoadRec [a]
loadBinaries String
name = do
    [RecItem]
items <- ((ByteString, RecItem) -> RecItem)
-> [(ByteString, RecItem)] -> [RecItem]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, RecItem) -> RecItem
forall a b. (a, b) -> b
snd ([(ByteString, RecItem)] -> [RecItem])
-> ([(ByteString, RecItem)] -> [(ByteString, RecItem)])
-> [(ByteString, RecItem)]
-> [RecItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, RecItem) -> Bool)
-> [(ByteString, RecItem)] -> [(ByteString, RecItem)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> ByteString
BC.pack String
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool)
-> ((ByteString, RecItem) -> ByteString)
-> (ByteString, RecItem)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, RecItem) -> ByteString
forall a b. (a, b) -> a
fst) ([(ByteString, RecItem)] -> [RecItem])
-> LoadRec [(ByteString, RecItem)] -> LoadRec [RecItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems
    [RecItem] -> (RecItem -> LoadRec a) -> LoadRec [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RecItem]
items ((RecItem -> LoadRec a) -> LoadRec [a])
-> (RecItem -> LoadRec a) -> LoadRec [a]
forall a b. (a -> b) -> a -> b
$ \case RecBinary ByteString
x -> a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> LoadRec a) -> a -> LoadRec a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert ByteString
x
                       RecItem
_ -> String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Expecting type binary of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadDate :: StorableDate a => String -> LoadRec a
loadDate :: forall a. StorableDate a => String -> LoadRec a
loadDate String
name = LoadRec a -> (a -> LoadRec a) -> Maybe a -> LoadRec a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Missing record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec a) -> LoadRec (Maybe a) -> LoadRec a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe a)
forall a. StorableDate a => String -> LoadRec (Maybe a)
loadMbDate String
name

loadMbDate :: StorableDate a => String -> LoadRec (Maybe a)
loadMbDate :: forall a. StorableDate a => String -> LoadRec (Maybe a)
loadMbDate String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe a)) -> LoadRec (Maybe a)
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just (RecDate ZonedTime
x) -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec (Maybe a)) -> Maybe a -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ ZonedTime -> a
forall a. StorableDate a => ZonedTime -> a
fromDate ZonedTime
x
    Just RecItem
_ -> String -> LoadRec (Maybe a)
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe a)) -> String -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"Expecting type date of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadUUID :: StorableUUID a => String -> LoadRec a
loadUUID :: forall a. StorableUUID a => String -> LoadRec a
loadUUID String
name = LoadRec a -> (a -> LoadRec a) -> Maybe a -> LoadRec a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec a
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec a) -> String -> LoadRec a
forall a b. (a -> b) -> a -> b
$ String
"Missing record iteem '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec a) -> LoadRec (Maybe a) -> LoadRec a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe a)
forall a. StorableUUID a => String -> LoadRec (Maybe a)
loadMbUUID String
name

loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a)
loadMbUUID :: forall a. StorableUUID a => String -> LoadRec (Maybe a)
loadMbUUID String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe a)) -> LoadRec (Maybe a)
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just (RecUUID UUID
x) -> Maybe a -> LoadRec (Maybe a)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> LoadRec (Maybe a)) -> Maybe a -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ UUID -> a
forall a. StorableUUID a => UUID -> a
fromUUID UUID
x
    Just RecItem
_ -> String -> LoadRec (Maybe a)
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe a)) -> String -> LoadRec (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"Expecting type UUID of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadRawRef :: String -> LoadRec Ref
loadRawRef :: String -> LoadRec Ref
loadRawRef String
name = LoadRec Ref -> (Ref -> LoadRec Ref) -> Maybe Ref -> LoadRec Ref
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> LoadRec Ref
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec Ref) -> String -> LoadRec Ref
forall a b. (a -> b) -> a -> b
$ String
"Missing record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'") Ref -> LoadRec Ref
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Ref -> LoadRec Ref) -> LoadRec (Maybe Ref) -> LoadRec Ref
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> LoadRec (Maybe Ref)
loadMbRawRef String
name

loadMbRawRef :: String -> LoadRec (Maybe Ref)
loadMbRawRef :: String -> LoadRec (Maybe Ref)
loadMbRawRef String
name = (ByteString -> [(ByteString, RecItem)] -> Maybe RecItem
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
BC.pack String
name) ([(ByteString, RecItem)] -> Maybe RecItem)
-> LoadRec [(ByteString, RecItem)] -> LoadRec (Maybe RecItem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems) LoadRec (Maybe RecItem)
-> (Maybe RecItem -> LoadRec (Maybe Ref)) -> LoadRec (Maybe Ref)
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe RecItem
Nothing -> Maybe Ref -> LoadRec (Maybe Ref)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Ref
forall a. Maybe a
Nothing
    Just (RecRef Ref
x) -> Maybe Ref -> LoadRec (Maybe Ref)
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ref -> Maybe Ref
forall a. a -> Maybe a
Just Ref
x)
    Just RecItem
_ -> String -> LoadRec (Maybe Ref)
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec (Maybe Ref)) -> String -> LoadRec (Maybe Ref)
forall a b. (a -> b) -> a -> b
$ String
"Expecting type ref of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadRawRefs :: String -> LoadRec [Ref]
loadRawRefs :: String -> LoadRec [Ref]
loadRawRefs String
name = do
    [RecItem]
items <- ((ByteString, RecItem) -> RecItem)
-> [(ByteString, RecItem)] -> [RecItem]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, RecItem) -> RecItem
forall a b. (a, b) -> b
snd ([(ByteString, RecItem)] -> [RecItem])
-> ([(ByteString, RecItem)] -> [(ByteString, RecItem)])
-> [(ByteString, RecItem)]
-> [RecItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, RecItem) -> Bool)
-> [(ByteString, RecItem)] -> [(ByteString, RecItem)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> ByteString
BC.pack String
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool)
-> ((ByteString, RecItem) -> ByteString)
-> (ByteString, RecItem)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, RecItem) -> ByteString
forall a b. (a, b) -> a
fst) ([(ByteString, RecItem)] -> [RecItem])
-> LoadRec [(ByteString, RecItem)] -> LoadRec [RecItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec [(ByteString, RecItem)]
loadRecItems
    [RecItem] -> (RecItem -> LoadRec Ref) -> LoadRec [Ref]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RecItem]
items ((RecItem -> LoadRec Ref) -> LoadRec [Ref])
-> (RecItem -> LoadRec Ref) -> LoadRec [Ref]
forall a b. (a -> b) -> a -> b
$ \case RecRef Ref
x -> Ref -> LoadRec Ref
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return Ref
x
                       RecItem
_ -> String -> LoadRec Ref
forall a. String -> LoadRec a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> LoadRec Ref) -> String -> LoadRec Ref
forall a b. (a -> b) -> a -> b
$ String
"Expecting type ref of record item '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'"

loadRef :: Storable a => String -> LoadRec a
loadRef :: forall a. Storable a => String -> LoadRec a
loadRef String
name = Ref -> a
forall a. Storable a => Ref -> a
load (Ref -> a) -> LoadRec Ref -> LoadRec a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec Ref
loadRawRef String
name

loadMbRef :: Storable a => String -> LoadRec (Maybe a)
loadMbRef :: forall a. Storable a => String -> LoadRec (Maybe a)
loadMbRef String
name = (Ref -> a) -> Maybe Ref -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref -> a
forall a. Storable a => Ref -> a
load (Maybe Ref -> Maybe a) -> LoadRec (Maybe Ref) -> LoadRec (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec (Maybe Ref)
loadMbRawRef String
name

loadRefs :: Storable a => String -> LoadRec [a]
loadRefs :: forall a. Storable a => String -> LoadRec [a]
loadRefs String
name = (Ref -> a) -> [Ref] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Ref -> a
forall a. Storable a => Ref -> a
load ([Ref] -> [a]) -> LoadRec [Ref] -> LoadRec [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec [Ref]
loadRawRefs String
name

loadZRef :: ZeroStorable a => String -> LoadRec a
loadZRef :: forall a. ZeroStorable a => String -> LoadRec a
loadZRef String
name = String -> LoadRec (Maybe a)
forall a. Storable a => String -> LoadRec (Maybe a)
loadMbRef String
name LoadRec (Maybe a) -> (Maybe a -> LoadRec a) -> LoadRec a
forall a b. LoadRec a -> (a -> LoadRec b) -> LoadRec b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Maybe a
Nothing -> do Ref Storage
st RefDigest
_ <- LoadRec Ref
loadRecCurrentRef
                                  a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> LoadRec a) -> a -> LoadRec a
forall a b. (a -> b) -> a -> b
$ Storage -> a
forall a. ZeroStorable a => Storage -> a
fromZero Storage
st
                    Just a
x  -> a -> LoadRec a
forall a. a -> LoadRec a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x


type Stored a = Stored' Complete a

instance Storable a => Storable (Stored a) where
    store :: forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> Stored a -> IO (Ref' c)
store Storage' c
st = Storage' c -> Ref -> IO (LoadResult Identity (Ref' c))
forall (c :: * -> *) (c' :: * -> *) (m :: * -> *).
(StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
copyRef Storage' c
st (Ref -> IO (Ref' c))
-> (Stored a -> Ref) -> Stored a -> IO (Ref' c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored a -> Ref
forall a. Stored a -> Ref
storedRef
    store' :: Stored a -> Store
store' (Stored Ref
_ a
x) = a -> Store
forall a. Storable a => a -> Store
store' a
x
    load' :: Load (Stored a)
load' = Ref -> a -> Stored a
forall (c :: * -> *) a. Ref' c -> a -> Stored' c a
Stored (Ref -> a -> Stored a) -> Load Ref -> Load (a -> Stored a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Load Ref
loadCurrentRef Load (a -> Stored a) -> Load a -> Load (Stored a)
forall a b. Load (a -> b) -> Load a -> Load b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Load a
forall a. Storable a => Load a
load'

instance ZeroStorable a => ZeroStorable (Stored a) where
    fromZero :: Storage -> Stored a
fromZero Storage
st = Ref -> a -> Stored a
forall (c :: * -> *) a. Ref' c -> a -> Stored' c a
Stored (Storage -> Ref
forall (c :: * -> *). Storage' c -> Ref' c
zeroRef Storage
st) (a -> Stored a) -> a -> Stored a
forall a b. (a -> b) -> a -> b
$ Storage -> a
forall a. ZeroStorable a => Storage -> a
fromZero Storage
st

fromStored :: Stored a -> a
fromStored :: forall a. Stored a -> a
fromStored (Stored Ref
_ a
x) = a
x

storedRef :: Stored a -> Ref
storedRef :: forall a. Stored a -> Ref
storedRef (Stored Ref
ref a
_) = Ref
ref

wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)
wrappedStore :: forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st a
x = do Ref
ref <- IO Ref -> m Ref
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Ref -> m Ref) -> IO Ref -> m Ref
forall a b. (a -> b) -> a -> b
$ Storage -> a -> IO Ref
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
Storage' c -> a -> IO (Ref' c)
forall (c :: * -> *).
StorageCompleteness c =>
Storage' c -> a -> IO (Ref' c)
store Storage
st a
x
                       Stored a -> m (Stored a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stored a -> m (Stored a)) -> Stored a -> m (Stored a)
forall a b. (a -> b) -> a -> b
$ Ref -> a -> Stored a
forall (c :: * -> *) a. Ref' c -> a -> Stored' c a
Stored Ref
ref a
x

wrappedLoad :: Storable a => Ref -> Stored a
wrappedLoad :: forall a. Storable a => Ref -> Stored a
wrappedLoad Ref
ref = Ref -> a -> Stored' Identity a
forall (c :: * -> *) a. Ref' c -> a -> Stored' c a
Stored Ref
ref (Ref -> a
forall a. Storable a => Ref -> a
load Ref
ref)

copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
    Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a))
copyStored :: forall (c :: * -> *) (c' :: * -> *) (m :: * -> *) a.
(StorageCompleteness c, StorageCompleteness c', MonadIO m) =>
Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a))
copyStored Storage' c'
st (Stored Ref' c
ref' a
x) = IO (LoadResult c (Stored' c' a)) -> m (LoadResult c (Stored' c' a))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LoadResult c (Stored' c' a))
 -> m (LoadResult c (Stored' c' a)))
-> IO (LoadResult c (Stored' c' a))
-> m (LoadResult c (Stored' c' a))
forall a b. (a -> b) -> a -> b
$ c (Stored' c' a) -> LoadResult c (Stored' c' a)
forall a. c a -> LoadResult c a
forall (compl :: * -> *) a.
StorageCompleteness compl =>
compl a -> LoadResult compl a
returnLoadResult (c (Stored' c' a) -> LoadResult c (Stored' c' a))
-> (c (Ref' c') -> c (Stored' c' a))
-> c (Ref' c')
-> LoadResult c (Stored' c' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ref' c' -> Stored' c' a) -> c (Ref' c') -> c (Stored' c' a)
forall a b. (a -> b) -> c a -> c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Ref' c' -> a -> Stored' c' a) -> a -> Ref' c' -> Stored' c' a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ref' c' -> a -> Stored' c' a
forall (c :: * -> *) a. Ref' c -> a -> Stored' c a
Stored a
x) (c (Ref' c') -> LoadResult c (Stored' c' a))
-> IO (c (Ref' c')) -> IO (LoadResult c (Stored' c' a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Storage' c' -> Ref' c -> IO (c (Ref' c'))
forall (c :: * -> *) (c' :: * -> *).
(StorageCompleteness c, StorageCompleteness c') =>
Storage' c' -> Ref' c -> IO (c (Ref' c'))
copyRef' Storage' c'
st Ref' c
ref'

-- |Passed function needs to preserve the object representation to be safe
unsafeMapStored :: (a -> b) -> Stored a -> Stored b
unsafeMapStored :: forall a b. (a -> b) -> Stored a -> Stored b
unsafeMapStored a -> b
f (Stored Ref
ref a
x) = Ref -> b -> Stored' Identity b
forall (c :: * -> *) a. Ref' c -> a -> Stored' c a
Stored Ref
ref (a -> b
f a
x)


data StoreInfo = StoreInfo
    { StoreInfo -> ZonedTime
infoDate :: ZonedTime
    , StoreInfo -> Maybe Text
infoNote :: Maybe Text
    }
    deriving (Int -> StoreInfo -> String -> String
[StoreInfo] -> String -> String
StoreInfo -> String
(Int -> StoreInfo -> String -> String)
-> (StoreInfo -> String)
-> ([StoreInfo] -> String -> String)
-> Show StoreInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> StoreInfo -> String -> String
showsPrec :: Int -> StoreInfo -> String -> String
$cshow :: StoreInfo -> String
show :: StoreInfo -> String
$cshowList :: [StoreInfo] -> String -> String
showList :: [StoreInfo] -> String -> String
Show)

makeStoreInfo :: IO StoreInfo
makeStoreInfo :: IO StoreInfo
makeStoreInfo = ZonedTime -> Maybe Text -> StoreInfo
StoreInfo
    (ZonedTime -> Maybe Text -> StoreInfo)
-> IO ZonedTime -> IO (Maybe Text -> StoreInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ZonedTime
getZonedTime
    IO (Maybe Text -> StoreInfo) -> IO (Maybe Text) -> IO StoreInfo
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing

storeInfoRec :: StoreInfo -> StoreRec c
storeInfoRec :: forall (c :: * -> *). StoreInfo -> StoreRec c
storeInfoRec StoreInfo
info = do
    String -> ZonedTime -> StoreRec c
forall a (c :: * -> *). StorableDate a => String -> a -> StoreRec c
storeDate String
"date" (ZonedTime -> StoreRec c) -> ZonedTime -> StoreRec c
forall a b. (a -> b) -> a -> b
$ StoreInfo -> ZonedTime
infoDate StoreInfo
info
    String -> Maybe Text -> StoreRec c
forall a (c :: * -> *).
StorableText a =>
String -> Maybe a -> StoreRec c
storeMbText String
"note" (Maybe Text -> StoreRec c) -> Maybe Text -> StoreRec c
forall a b. (a -> b) -> a -> b
$ StoreInfo -> Maybe Text
infoNote StoreInfo
info

loadInfoRec :: LoadRec StoreInfo
loadInfoRec :: LoadRec StoreInfo
loadInfoRec = ZonedTime -> Maybe Text -> StoreInfo
StoreInfo
    (ZonedTime -> Maybe Text -> StoreInfo)
-> LoadRec ZonedTime -> LoadRec (Maybe Text -> StoreInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> LoadRec ZonedTime
forall a. StorableDate a => String -> LoadRec a
loadDate String
"date"
    LoadRec (Maybe Text -> StoreInfo)
-> LoadRec (Maybe Text) -> LoadRec StoreInfo
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe Text)
forall a. StorableText a => String -> LoadRec (Maybe a)
loadMbText String
"note"


data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a))
    deriving (Int -> History a -> String -> String
[History a] -> String -> String
History a -> String
(Int -> History a -> String -> String)
-> (History a -> String)
-> ([History a] -> String -> String)
-> Show (History a)
forall a. Show a => Int -> History a -> String -> String
forall a. Show a => [History a] -> String -> String
forall a. Show a => History a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Show a => Int -> History a -> String -> String
showsPrec :: Int -> History a -> String -> String
$cshow :: forall a. Show a => History a -> String
show :: History a -> String
$cshowList :: forall a. Show a => [History a] -> String -> String
showList :: [History a] -> String -> String
Show)

type StoredHistory a = Stored (History a)

instance Storable a => Storable (History a) where
    store' :: History a -> Store
store' (History StoreInfo
si Stored a
x Maybe (StoredHistory a)
prev) = (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
storeRec ((forall (c :: * -> *). StorageCompleteness c => StoreRec c)
 -> Store)
-> (forall (c :: * -> *). StorageCompleteness c => StoreRec c)
-> Store
forall a b. (a -> b) -> a -> b
$ do
        StoreInfo -> StoreRec c
forall (c :: * -> *). StoreInfo -> StoreRec c
storeInfoRec StoreInfo
si
        String -> Maybe (StoredHistory a) -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> Maybe a -> StoreRec c
storeMbRef String
"prev" Maybe (StoredHistory a)
prev
        String -> Stored a -> StoreRec c
forall a (c :: * -> *).
(Storable a, StorageCompleteness c) =>
String -> a -> StoreRec c
storeRef String
"item" Stored a
x

    load' :: Load (History a)
load' = LoadRec (History a) -> Load (History a)
forall a. LoadRec a -> Load a
loadRec (LoadRec (History a) -> Load (History a))
-> LoadRec (History a) -> Load (History a)
forall a b. (a -> b) -> a -> b
$ StoreInfo -> Stored a -> Maybe (StoredHistory a) -> History a
forall a.
StoreInfo -> Stored a -> Maybe (StoredHistory a) -> History a
History
        (StoreInfo -> Stored a -> Maybe (StoredHistory a) -> History a)
-> LoadRec StoreInfo
-> LoadRec (Stored a -> Maybe (StoredHistory a) -> History a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LoadRec StoreInfo
loadInfoRec
        LoadRec (Stored a -> Maybe (StoredHistory a) -> History a)
-> LoadRec (Stored a)
-> LoadRec (Maybe (StoredHistory a) -> History a)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Stored a)
forall a. Storable a => String -> LoadRec a
loadRef String
"item"
        LoadRec (Maybe (StoredHistory a) -> History a)
-> LoadRec (Maybe (StoredHistory a)) -> LoadRec (History a)
forall a b. LoadRec (a -> b) -> LoadRec a -> LoadRec b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> LoadRec (Maybe (StoredHistory a))
forall a. Storable a => String -> LoadRec (Maybe a)
loadMbRef String
"prev"

fromHistory :: StoredHistory a -> a
fromHistory :: forall a. StoredHistory a -> a
fromHistory = Stored a -> a
forall a. Stored a -> a
fromStored (Stored a -> a)
-> (StoredHistory a -> Stored a) -> StoredHistory a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoredHistory a -> Stored a
forall a. StoredHistory a -> Stored a
storedFromHistory

fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a
fromHistoryAt :: forall a. ZonedTime -> StoredHistory a -> Maybe a
fromHistoryAt ZonedTime
zat = ((ZonedTime, Stored a) -> a)
-> Maybe (ZonedTime, Stored a) -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Stored a -> a
forall a. Stored a -> a
fromStored (Stored a -> a)
-> ((ZonedTime, Stored a) -> Stored a)
-> (ZonedTime, Stored a)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonedTime, Stored a) -> Stored a
forall a b. (a, b) -> b
snd) (Maybe (ZonedTime, Stored a) -> Maybe a)
-> (StoredHistory a -> Maybe (ZonedTime, Stored a))
-> StoredHistory a
-> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ZonedTime, Stored a)] -> Maybe (ZonedTime, Stored a)
forall a. [a] -> Maybe a
listToMaybe ([(ZonedTime, Stored a)] -> Maybe (ZonedTime, Stored a))
-> (StoredHistory a -> [(ZonedTime, Stored a)])
-> StoredHistory a
-> Maybe (ZonedTime, Stored a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ZonedTime, Stored a) -> Bool)
-> [(ZonedTime, Stored a)] -> [(ZonedTime, Stored a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((UTCTime
atUTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<) (UTCTime -> Bool)
-> ((ZonedTime, Stored a) -> UTCTime)
-> (ZonedTime, Stored a)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> UTCTime
zonedTimeToUTC (ZonedTime -> UTCTime)
-> ((ZonedTime, Stored a) -> ZonedTime)
-> (ZonedTime, Stored a)
-> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ZonedTime, Stored a) -> ZonedTime
forall a b. (a, b) -> a
fst) ([(ZonedTime, Stored a)] -> [(ZonedTime, Stored a)])
-> (StoredHistory a -> [(ZonedTime, Stored a)])
-> StoredHistory a
-> [(ZonedTime, Stored a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoredHistory a -> [(ZonedTime, Stored a)]
forall a. StoredHistory a -> [(ZonedTime, Stored a)]
storedHistoryTimedList
    where at :: UTCTime
at = ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
zat

storedFromHistory :: StoredHistory a -> Stored a
storedFromHistory :: forall a. StoredHistory a -> Stored a
storedFromHistory StoredHistory a
sh = let History StoreInfo
_ Stored a
item Maybe (StoredHistory a)
_ = StoredHistory a -> History a
forall a. Stored a -> a
fromStored StoredHistory a
sh
                        in Stored a
item

storedHistoryList :: StoredHistory a -> [Stored a]
storedHistoryList :: forall a. StoredHistory a -> [Stored a]
storedHistoryList = ((ZonedTime, Stored a) -> Stored a)
-> [(ZonedTime, Stored a)] -> [Stored a]
forall a b. (a -> b) -> [a] -> [b]
map (ZonedTime, Stored a) -> Stored a
forall a b. (a, b) -> b
snd ([(ZonedTime, Stored a)] -> [Stored a])
-> (StoredHistory a -> [(ZonedTime, Stored a)])
-> StoredHistory a
-> [Stored a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoredHistory a -> [(ZonedTime, Stored a)]
forall a. StoredHistory a -> [(ZonedTime, Stored a)]
storedHistoryTimedList

storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)]
storedHistoryTimedList :: forall a. StoredHistory a -> [(ZonedTime, Stored a)]
storedHistoryTimedList StoredHistory a
sh = let History StoreInfo
hinfo Stored a
item Maybe (StoredHistory a)
prev = StoredHistory a -> History a
forall a. Stored a -> a
fromStored StoredHistory a
sh
                             in (StoreInfo -> ZonedTime
infoDate StoreInfo
hinfo, Stored a
item) (ZonedTime, Stored a)
-> [(ZonedTime, Stored a)] -> [(ZonedTime, Stored a)]
forall a. a -> [a] -> [a]
: [(ZonedTime, Stored a)]
-> (StoredHistory a -> [(ZonedTime, Stored a)])
-> Maybe (StoredHistory a)
-> [(ZonedTime, Stored a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] StoredHistory a -> [(ZonedTime, Stored a)]
forall a. StoredHistory a -> [(ZonedTime, Stored a)]
storedHistoryTimedList Maybe (StoredHistory a)
prev

beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a)
beginHistory :: forall a.
Storable a =>
Storage -> StoreInfo -> a -> IO (StoredHistory a)
beginHistory Storage
st StoreInfo
si a
x = do Stored a
sx <- Storage -> a -> IO (Stored a)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st a
x
                          Storage -> History a -> IO (StoredHistory a)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st (History a -> IO (StoredHistory a))
-> History a -> IO (StoredHistory a)
forall a b. (a -> b) -> a -> b
$ StoreInfo -> Stored a -> Maybe (StoredHistory a) -> History a
forall a.
StoreInfo -> Stored a -> Maybe (StoredHistory a) -> History a
History StoreInfo
si Stored a
sx Maybe (StoredHistory a)
forall a. Maybe a
Nothing

modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a)
modifyHistory :: forall a.
Storable a =>
StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a)
modifyHistory StoreInfo
si a -> a
f prev :: StoredHistory a
prev@(Stored (Ref Storage
st RefDigest
_) History a
_) = do
    Stored a
sx <- Storage -> a -> IO (Stored a)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st (a -> IO (Stored a)) -> a -> IO (Stored a)
forall a b. (a -> b) -> a -> b
$ a -> a
f (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ StoredHistory a -> a
forall a. StoredHistory a -> a
fromHistory StoredHistory a
prev
    Storage -> History a -> IO (StoredHistory a)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore Storage
st (History a -> IO (StoredHistory a))
-> History a -> IO (StoredHistory a)
forall a b. (a -> b) -> a -> b
$ StoreInfo -> Stored a -> Maybe (StoredHistory a) -> History a
forall a.
StoreInfo -> Stored a -> Maybe (StoredHistory a) -> History a
History StoreInfo
si Stored a
sx (StoredHistory a -> Maybe (StoredHistory a)
forall a. a -> Maybe a
Just StoredHistory a
prev)


showRatio :: Rational -> String
showRatio :: Rational -> String
showRatio Rational
r = case Rational -> Maybe (Integer, Integer)
decimalRatio Rational
r of
                   Just (Integer
n, Integer
1) -> Integer -> String
forall a. Show a => a -> String
show Integer
n
                   Just (Integer
n', Integer
d) -> let n :: Integer
n = Integer -> Integer
forall a. Num a => a -> a
abs Integer
n'
                                    in (if Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then String
"-" else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                       (((Integer, Integer) -> String) -> [(Integer, Integer)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Integer -> String
forall a. Show a => a -> String
show(Integer -> String)
-> ((Integer, Integer) -> Integer) -> (Integer, Integer) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
10)(Integer -> Integer)
-> ((Integer, Integer) -> Integer) -> (Integer, Integer) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Integer, Integer) -> Integer
forall a b. (a, b) -> b
snd) ([(Integer, Integer)] -> String) -> [(Integer, Integer)] -> String
forall a b. (a -> b) -> a -> b
$ [(Integer, Integer)] -> [(Integer, Integer)]
forall a. [a] -> [a]
reverse ([(Integer, Integer)] -> [(Integer, Integer)])
-> [(Integer, Integer)] -> [(Integer, Integer)]
forall a b. (a -> b) -> a -> b
$ ((Integer, Integer) -> Bool)
-> [(Integer, Integer)] -> [(Integer, Integer)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
1)(Integer -> Bool)
-> ((Integer, Integer) -> Integer) -> (Integer, Integer) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Integer, Integer) -> Integer
forall a b. (a, b) -> a
fst) ([(Integer, Integer)] -> [(Integer, Integer)])
-> [(Integer, Integer)] -> [(Integer, Integer)]
forall a b. (a -> b) -> a -> b
$ [Integer] -> [Integer] -> [(Integer, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Integer -> Integer) -> Integer -> [Integer]
forall a. (a -> a) -> a -> [a]
iterate (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
10) Integer
d) ((Integer -> Integer) -> Integer -> [Integer]
forall a. (a -> a) -> a -> [a]
iterate (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
10) (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
d)))
                   Maybe (Integer, Integer)
Nothing -> Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r)

decimalRatio :: Rational -> Maybe (Integer, Integer)
decimalRatio :: Rational -> Maybe (Integer, Integer)
decimalRatio Rational
r = do
    let n :: Integer
n = Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r
        d :: Integer
d = Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r
        (Integer
c2, Integer
d') = Integer -> Integer -> (Integer, Integer)
takeFactors Integer
2 Integer
d
        (Integer
c5, Integer
d'') = Integer -> Integer -> (Integer, Integer)
takeFactors Integer
5 Integer
d'
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Integer
d'' Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
    let m :: Integer
m = if Integer
c2 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
c5 then Integer
5 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
c2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c5)
                       else Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
c5 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
c2)
    (Integer, Integer) -> Maybe (Integer, Integer)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
m, Integer
d Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
m)

takeFactors :: Integer -> Integer -> (Integer, Integer)
takeFactors :: Integer -> Integer -> (Integer, Integer)
takeFactors Integer
f Integer
n | Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
f Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = let (Integer
c, Integer
n') = Integer -> Integer -> (Integer, Integer)
takeFactors Integer
f (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
f)
                                    in (Integer
cInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, Integer
n')
                | Bool
otherwise = (Integer
0, Integer
n)

parseRatio :: ByteString -> Maybe Rational
parseRatio :: ByteString -> Maybe Rational
parseRatio ByteString
bs = case (Char -> Char -> Bool) -> ByteString -> [ByteString]
BC.groupBy (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bool -> Bool -> Bool) -> (Char -> Bool) -> Char -> Char -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Char -> Bool
isNumber) ByteString
bs of
                     (ByteString
m:[ByteString]
xs) | ByteString
m ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== String -> ByteString
BC.pack String
"-" -> Rational -> Rational
forall a. Num a => a -> a
negate (Rational -> Rational) -> Maybe Rational -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString] -> Maybe Rational
positive [ByteString]
xs
                     [ByteString]
xs                        -> [ByteString] -> Maybe Rational
positive [ByteString]
xs
    where positive :: [ByteString] -> Maybe Rational
positive = \case
              [ByteString
bx] -> Integer -> Rational
forall a. Num a => Integer -> a
fromInteger (Integer -> Rational)
-> ((Integer, ByteString) -> Integer)
-> (Integer, ByteString)
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, ByteString) -> Integer
forall a b. (a, b) -> a
fst ((Integer, ByteString) -> Rational)
-> Maybe (Integer, ByteString) -> Maybe Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Integer, ByteString)
BC.readInteger ByteString
bx
              [ByteString
bx, ByteString
op, ByteString
by] -> do
                  (Integer
x, ByteString
_) <- ByteString -> Maybe (Integer, ByteString)
BC.readInteger ByteString
bx
                  (Integer
y, ByteString
_) <- ByteString -> Maybe (Integer, ByteString)
BC.readInteger ByteString
by
                  case ByteString -> String
BC.unpack ByteString
op of
                       String
"." -> Rational -> Maybe Rational
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Maybe Rational) -> Rational -> Maybe Rational
forall a b. (a -> b) -> a -> b
$ (Integer
x Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Integer
y Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% (Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ ByteString -> Int
BC.length ByteString
by))
                       String
"/" -> Rational -> Maybe Rational
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Maybe Rational) -> Rational -> Maybe Rational
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
y
                       String
_   -> Maybe Rational
forall a. Maybe a
Nothing
              [ByteString]
_ -> Maybe Rational
forall a. Maybe a
Nothing