module Erebos.Object.Internal (
    Storage, PartialStorage, StorageCompleteness,

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

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

    MonadStorage(..),

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

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

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

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

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

import Control.Applicative
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer

import Crypto.Hash

import Data.Bifunctor
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Lazy.Char8 qualified as BLC
import Data.Char
import Data.Function
import Data.Maybe
import Data.Ratio
import Data.Set (Set)
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified 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.Word

import System.IO.Unsafe

import Erebos.Error
import Erebos.Storage.Internal
import Erebos.UUID (UUID)
import Erebos.UUID qualified as U
import Erebos.Util


zeroRef :: Storage' c -> Ref' c
zeroRef s = Ref s (RefDigest h)
    where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of
                   Nothing -> error $ "Failed to create zero hash"
                   Just h' -> h'
          digestAlgo :: Digest a -> a
          digestAlgo = undefined

isZeroRef :: Ref' c -> Bool
isZeroRef (Ref _ h) = all (==0) $ BA.unpack h


refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c))
refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst

readRef :: Storage -> ByteString -> IO (Maybe Ref)
readRef s b =
    case readRefDigest b of
         Nothing -> return Nothing
         Just dgst -> refFromDigest s dgst

copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c'))
copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref
                                                                Nothing  -> doCopy
    where doCopy = do mbobj' <- ioLoadObject ref'
                      mbobj <- sequence $ copyObject' st <$> mbobj'
                      sequence $ unsafeStoreObject st <$> join mbobj

copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c'))
copyRecItem' st = \case
    RecEmpty -> return $ return $ RecEmpty
    RecInt x -> return $ return $ RecInt x
    RecNum x -> return $ return $ RecNum x
    RecText x -> return $ return $ RecText x
    RecBinary x -> return $ return $ RecBinary x
    RecDate x -> return $ return $ RecDate x
    RecUUID x -> return $ return $ RecUUID x
    RecRef x -> fmap RecRef <$> copyRef' st x
    RecWeak x -> return $ return $ RecWeak x
    RecUnknown t x -> return $ return $ RecUnknown t x

copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c'))
copyObject' _ (Blob bs) = return $ return $ Blob bs
copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs
copyObject' _ (OnDemand size dgst) = return $ return $ OnDemand size dgst
copyObject' _ ZeroObject = return $ return ZeroObject
copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content

copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c'))
copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref'

copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c'))
copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item'

copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c'))
copyObject st obj' = returnLoadResult <$> copyObject' st obj'

partialRef :: PartialStorage -> Ref -> PartialRef
partialRef st (Ref _ dgst) = Ref st dgst

partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef
partialRefFromDigest st dgst = Ref st dgst


data Object' c
    = Blob ByteString
    | Rec [ ( ByteString, RecItem' c ) ]
    | OnDemand Word64 RefDigest
    | ZeroObject
    | UnknownObject ByteString ByteString
    deriving (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)
    | RecWeak RefDigest
    | RecUnknown ByteString ByteString
    deriving (Show)

type RecItem = RecItem' Complete

serializeObject :: Object' c -> BL.ByteString
serializeObject = \case
    Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
    Rec rec ->
        let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec
         in BL.fromChunks [ BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n' ] `BL.append` cnt
    OnDemand size dgst ->
        let cnt = BC.unlines [ BC.pack (show size), showRefDigest dgst ]
         in BL.fromChunks [ BC.pack "ondemand ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]
    ZeroObject -> BL.empty
    UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ]

-- |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 storage = \case
    ZeroObject -> return $ zeroRef storage
    obj -> unsafeStoreRawBytes storage $ serializeObject obj

storeObject :: PartialStorage -> PartialObject -> IO PartialRef
storeObject = unsafeStoreObject

storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
storeRawBytes = unsafeStoreRawBytes

unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
unsafeStoreRawBytes st@Storage {..} raw = do
    dgst <- evaluate $ force $ hashToRefDigest raw
    backendStoreBytes stBackend dgst raw
    return $ Ref st dgst

serializeRecItem :: ByteString -> RecItem' c -> [ByteString]
serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n']
serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n']
serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n']
serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n']
    where escaped = BC.concatMap escape $ encodeUtf8 x
          escape '\n' = BC.pack "\n\t"
          escape c    = BC.singleton c
serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n']
serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n']
serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n']
serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n']
serializeRecItem name (RecWeak x) = [name, BC.pack ":w ", showRefDigest x, BC.singleton '\n']
serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ]

lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c)
lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject

ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c))
ioLoadObject ref | isZeroRef ref = return $ return ZeroObject
ioLoadObject ref@(Ref st rhash) = do
    file' <- ioLoadBytes ref
    return $ do
        file <- file'
        let chash = hashToRefDigest file
        when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -}
        return $ case runExcept $ unsafeDeserializeObject st file of
                      Left err -> error $ showErebosError err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}
                      Right (x, rest) | BL.null rest -> x
                                      | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -}

lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString
lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString)
lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref

unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString)
unsafeDeserializeObject _  bytes | BL.null bytes = return (ZeroObject, bytes)
unsafeDeserializeObject st bytes =
    case BLC.break (=='\n') bytes of
        (line, rest) | Just (otype, len) <- splitObjPrefix line -> do
            let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest
            guard $ B.length content == len
            (, next) <$> if
                | otype == BC.pack "blob"
                    -> return $ Blob content
                | otype == BC.pack "rec"
                , Just ritems <- parseRecordBody st content
                    -> return $ Rec ritems
                | otype == BC.pack "ondemand"
                , Just ondemand <- parseOnDemand st content
                    -> return ondemand
                | otherwise
                    -> return $ UnknownObject otype content
        _ -> throwOtherError $ "malformed object"
  where
    splitObjPrefix line = do
        [ otype, tlen ] <- return $ BLC.words line
        ( len, rest ) <- BLC.readInt tlen
        guard $ BL.null rest
        return ( BL.toStrict otype, len )

parseRecordBody :: Storage' c -> ByteString -> Maybe [ ( ByteString, RecItem' c ) ]
parseRecordBody _ body | B.null body = Just []
parseRecordBody st body = do
    colon <- BC.elemIndex ':' body
    space <- BC.elemIndex ' ' $ B.drop (colon + 1) body
    let name = B.take colon body
        itype = B.take space $ B.drop (colon + 1) body
    ( content, remainingBody ) <- parseTabEscapedLines $ B.drop (space + colon + 2) body

    let val = fromMaybe (RecUnknown itype content) $
            case BC.unpack itype of
                "e" -> do guard $ B.null content
                          return RecEmpty
                "i" -> do ( num, rest ) <- BC.readInteger content
                          guard $ B.null rest
                          return $ RecInt num
                "n" -> RecNum <$> parseRatio content
                "t" -> return $ RecText $ decodeUtf8With lenientDecode content
                "b" -> RecBinary <$> readHex content
                "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content)
                "u" -> RecUUID <$> U.fromASCIIBytes content
                "r" -> RecRef . Ref st <$> readRefDigest content
                "w" -> RecWeak <$> readRefDigest content
                _   -> Nothing
    (( name, val ) :) <$> parseRecordBody st remainingBody

-- Split given ByteString on the first newline not preceded by tab; replace
-- "\t\n" in the first part with "\n".
parseTabEscapedLines :: ByteString -> Maybe ( ByteString, ByteString )
parseTabEscapedLines = parseLines []
  where
    parseLines linesReversed cur = do
        newline <- BC.elemIndex '\n' cur
        case ( BC.length cur > newline + 1, BC.index cur (newline + 1) ) of
            ( True, '\t' ) -> parseLines (B.take (newline + 1) cur : linesReversed) (B.drop (newline + 2) cur)
            _              -> Just ( BC.concat $ reverse $ B.take newline cur : linesReversed, B.drop (newline + 1) cur )

parseOnDemand :: Storage' c -> ByteString -> Maybe (Object' c)
parseOnDemand _ body = do
    newline1 <- BC.elemIndex '\n' body
    newline2 <- BC.elemIndex '\n' $ B.drop (newline1 + 1) body
    guard (newline1 + newline2 + 2 == B.length body)
    ( size, sizeRest ) <- BC.readInt (B.take newline1 body)
    guard (B.null sizeRest)
    dgst <- readRefDigest $ B.take newline2 $ B.drop (newline1 + 1) body
    return $ OnDemand (fromIntegral size) dgst


deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString)
deserializeObject = unsafeDeserializeObject

deserializeObjects :: PartialStorage -> BL.ByteString -> Except ErebosError [PartialObject]
deserializeObjects _  bytes | BL.null bytes = return []
deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes
                                 (obj:) <$> deserializeObjects st rest


collectObjects :: Object -> [Object]
collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj)

collectStoredObjects :: Stored Object -> [Stored Object]
collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj)

collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest)
collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items
    where helper (RecRef ref) (xs, s) | r <- refDigest ref
                                      , r `S.notMember` s
                                      = let o = wrappedLoad ref
                                            (xs', s') = collectOtherStored (S.insert r s) $ fromStored o
                                         in ((o : xs') ++ xs, s')
          helper _          (xs, s) = (xs, s)
collectOtherStored seen _ = ([], seen)


deriving instance StorableUUID HeadID
deriving instance StorableUUID HeadTypeID


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 x = do
        st <- getStorage
        wrappedStore st x

instance MonadIO m => MonadStorage (ReaderT Storage m) where
    getStorage = ask


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

    store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c)
    store st = evalStore st . store'
    load :: Ref -> a
    load = evalLoad 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)]])
    | StoreOnDemand Word64 RefDigest
    | StoreZero
    | StoreUnknown ByteString ByteString

evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c)
evalStore st = unsafeStoreObject st <=< evalStoreObject st

evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c)
evalStoreObject _ (StoreBlob x) = return $ Blob x
evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s)
evalStoreObject _ (StoreOnDemand size dgst) = return $ OnDemand size dgst
evalStoreObject _ StoreZero = return ZeroObject
evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content

newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a)
    deriving (Functor, Applicative, Monad)

type StoreRec c = StoreRecM c ()

newtype Load a = Load (ReaderT (Ref, Object) (Except ErebosError) a)
    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError)

evalLoad :: Load a -> Ref -> a
evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $
    runExcept $ runReaderT f (ref, lazyLoadObject ref)

loadCurrentRef :: Load Ref
loadCurrentRef = Load $ asks fst

loadCurrentObject :: Load Object
loadCurrentObject = Load $ asks snd

newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except ErebosError) a)
    deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError)

loadRecCurrentRef :: LoadRec Ref
loadRecCurrentRef = LoadRec $ asks fst

loadRecItems :: LoadRec [(ByteString, RecItem)]
loadRecItems = LoadRec $ asks snd


instance Storable Object where
    store' (Blob bs) = StoreBlob bs
    store' (Rec xs) = StoreRec $ \st -> return $ do
        Rec xs' <- copyObject st (Rec xs)
        return xs'
    store' (OnDemand size dgst) = StoreOnDemand size dgst
    store' ZeroObject = StoreZero
    store' (UnknownObject otype content) = StoreUnknown otype content

    load' = loadCurrentObject

    store st = unsafeStoreObject st <=< copyObject st
    load = lazyLoadObject

instance Storable ByteString where
    store' = storeBlob
    load' = loadBlob id

instance Storable a => Storable [a] where
    store' []     = storeZero
    store' (x:xs) = storeRec $ do
        storeRef "i" x
        storeRef "n" xs

    load' = loadCurrentObject >>= \case
                ZeroObject -> return []
                _          -> loadRec $ (:)
                                  <$> loadRef "i"
                                  <*> loadRef "n"

instance Storable a => ZeroStorable [a] where
    fromZero _ = []


storeBlob :: ByteString -> Store
storeBlob = StoreBlob

storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store
storeRec sr = StoreRec $ do
    let StoreRecM r = sr
    execWriter . runReaderT r

storeZero :: Store
storeZero = StoreZero


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

instance StorableText Text where
    toText = id; fromText = return

instance StorableText [Char] where
    toText = T.pack; fromText = return . T.unpack


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

instance StorableDate ZonedTime where
    toDate = id; fromDate = id

instance StorableDate UTCTime where
    toDate = utcToZonedTime utc
    fromDate = zonedTimeToUTC

instance StorableDate Day where
    toDate day = toDate $ UTCTime day 0
    fromDate = utctDay . fromDate


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

instance StorableUUID UUID where
    toUUID = id; fromUUID = id


storeEmpty :: String -> StoreRec c
storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]]

storeMbEmpty :: String -> Maybe () -> StoreRec c
storeMbEmpty name = maybe (return ()) (const $ storeEmpty name)

storeInt :: Integral a => String -> a -> StoreRec c
storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]]

storeMbInt :: Integral a => String -> Maybe a -> StoreRec c
storeMbInt name = maybe (return ()) (storeInt name)

storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c
storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]]

storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c
storeMbNum name = maybe (return ()) (storeNum name)

storeText :: StorableText a => String -> a -> StoreRec c
storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]]

storeMbText :: StorableText a => String -> Maybe a -> StoreRec c
storeMbText name = maybe (return ()) (storeText name)

storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c
storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]]

storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c
storeMbBinary name = maybe (return ()) (storeBinary name)

storeDate :: StorableDate a => String -> a -> StoreRec c
storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]]

storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c
storeMbDate name = maybe (return ()) (storeDate name)

storeUUID :: StorableUUID a => String -> a -> StoreRec c
storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]]

storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c
storeMbUUID name = maybe (return ()) (storeUUID name)

storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
storeRef name x = StoreRecM $ do
    s <- ask
    tell $ (:[]) $ do
        ref <- store s x
        return [(BC.pack name, RecRef ref)]

storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c
storeMbRef name = maybe (return ()) (storeRef name)

storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c
storeRawRef name ref = StoreRecM $ do
    st <- ask
    tell $ (:[]) $ do
        ref' <- copyRef st ref
        return [(BC.pack name, RecRef ref')]

storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c
storeMbRawRef name = maybe (return ()) (storeRawRef name)

storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
storeZRef name x = StoreRecM $ do
    s <- ask
    tell $ (:[]) $ do
        ref <- store s x
        return $ if isZeroRef ref then []
                                  else [(BC.pack name, RecRef ref)]

storeWeak :: Storable a => StorageCompleteness c => String -> a -> StoreRec c
storeWeak name x = StoreRecM $ do
    s <- ask
    tell $ (:[]) $ do
        ref <- store s x
        return [ ( BC.pack name, RecWeak $ refDigest ref ) ]

storeMbWeak :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c
storeMbWeak name = maybe (return ()) (storeWeak name)

storeRawWeak :: StorageCompleteness c => String -> RefDigest -> StoreRec c
storeRawWeak name dgst = StoreRecM $ do
    tell $ (:[]) $ do
        return [ ( BC.pack name, RecWeak dgst ) ]

storeMbRawWeak :: StorageCompleteness c => String -> Maybe RefDigest -> StoreRec c
storeMbRawWeak name = maybe (return ()) (storeRawWeak name)

storeZWeak :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c
storeZWeak name x = StoreRecM $ do
    s <- ask
    tell $ (:[]) $ do
        ref <- store s x
        return $ if isZeroRef ref then []
                                  else [ ( BC.pack name, RecWeak $ refDigest ref ) ]


storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c
storeRecItems items = StoreRecM $ do
    st <- ask
    tell $ flip map items $ \( name, value ) -> do
        value' <- copyRecItem st value
        return [ ( name, value' ) ]

loadBlob :: (ByteString -> a) -> Load a
loadBlob f = loadCurrentObject >>= \case
    Blob x -> return $ f x
    _      -> throwOtherError "Expecting blob"

loadRec :: LoadRec a -> Load a
loadRec (LoadRec lrec) = loadCurrentObject >>= \case
    Rec rs -> do
        ref <- loadCurrentRef
        either throwError return $ runExcept $ runReaderT lrec (ref, rs)
    _ -> throwOtherError "Expecting record"

loadZero :: a -> Load a
loadZero x = loadCurrentObject >>= \case
    ZeroObject -> return x
    _          -> throwOtherError "Expecting zero"


loadEmpty :: String -> LoadRec ()
loadEmpty name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name

loadMbEmpty :: String -> LoadRec (Maybe ())
loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecEmpty ) | name' == bname
        = Just ()
    p _ = Nothing

loadInt :: Num a => String -> LoadRec a
loadInt name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbInt name

loadMbInt :: Num a => String -> LoadRec (Maybe a)
loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecInt x ) | name' == bname
        = Just (fromInteger x)
    p _ = Nothing

loadNum :: (Real a, Fractional a) => String -> LoadRec a
loadNum name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbNum name

loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a)
loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecNum x ) | name' == bname
        = Just (fromRational x)
    p _ = Nothing

loadText :: StorableText a => String -> LoadRec a
loadText name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbText name

loadMbText :: StorableText a => String -> LoadRec (Maybe a)
loadMbText name = listToMaybe <$> loadTexts name

loadTexts :: StorableText a => String -> LoadRec [a]
loadTexts name = sequence . mapMaybe p =<< loadRecItems
  where
    bname = BC.pack name
    p ( name', RecText x ) | name' == bname
        = Just (fromText x)
    p _ = Nothing

loadBinary :: BA.ByteArray a => String -> LoadRec a
loadBinary name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbBinary name

loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a)
loadMbBinary name = listToMaybe <$> loadBinaries name

loadBinaries :: BA.ByteArray a => String -> LoadRec [a]
loadBinaries name = mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecBinary x ) | name' == bname
        = Just (BA.convert x)
    p _ = Nothing

loadDate :: StorableDate a => String -> LoadRec a
loadDate name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbDate name

loadMbDate :: StorableDate a => String -> LoadRec (Maybe a)
loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecDate x ) | name' == bname
        = Just (fromDate x)
    p _ = Nothing

loadUUID :: StorableUUID a => String -> LoadRec a
loadUUID name = maybe (throwOtherError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name

loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a)
loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecUUID x ) | name' == bname
        = Just (fromUUID x)
    p _ = Nothing

loadRawRef :: String -> LoadRec Ref
loadRawRef name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name

loadMbRawRef :: String -> LoadRec (Maybe Ref)
loadMbRawRef name = listToMaybe <$> loadRawRefs name

loadRawRefs :: String -> LoadRec [Ref]
loadRawRefs name = mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecRef x ) | name' == bname = Just x
    p _                                    = Nothing

loadRef :: Storable a => String -> LoadRec a
loadRef name = load <$> loadRawRef name

loadMbRef :: Storable a => String -> LoadRec (Maybe a)
loadMbRef name = fmap load <$> loadMbRawRef name

loadRefs :: Storable a => String -> LoadRec [a]
loadRefs name = map load <$> loadRawRefs name

loadZRef :: ZeroStorable a => String -> LoadRec a
loadZRef name = loadMbRef name >>= \case
                    Nothing -> do Ref st _ <- loadRecCurrentRef
                                  return $ fromZero st
                    Just x  -> return x

loadRawWeak :: String -> LoadRec RefDigest
loadRawWeak name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawWeak name

loadMbRawWeak :: String -> LoadRec (Maybe RefDigest)
loadMbRawWeak name = listToMaybe <$> loadRawWeaks name

loadRawWeaks :: String -> LoadRec [ RefDigest ]
loadRawWeaks name = mapMaybe p <$> loadRecItems
  where
    bname = BC.pack name
    p ( name', RecRef x )  | name' == bname = Just (refDigest x)
    p ( name', RecWeak x ) | name' == bname = Just x
    p _                                     = Nothing



instance Storable a => Storable (Stored a) where
    store st = copyRef st . storedRef
    store' (Stored _ x) = store' x
    load' = Stored <$> loadCurrentRef <*> load'

instance ZeroStorable a => ZeroStorable (Stored a) where
    fromZero st = Stored (zeroRef st) $ fromZero st

fromStored :: Stored a -> a
fromStored = storedObject'

storedRef :: Stored a -> Ref
storedRef = storedRef'

wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a)
wrappedStore st x = do ref <- liftIO $ store st x
                       return $ Stored ref x

wrappedLoad :: Storable a => Ref -> Stored a
wrappedLoad ref = Stored ref (load ref)

copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a)
copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref'

-- |Passed function needs to preserve the object representation to be safe
unsafeMapStored :: (a -> b) -> Stored a -> Stored b
unsafeMapStored f (Stored ref x) = Stored ref (f x)


showRatio :: Rational -> String
showRatio r = case decimalRatio r of
                   Just (n, 1) -> show n
                   Just (n', d) -> let n = abs n'
                                    in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++
                                       (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d)))
                   Nothing -> show (numerator r) ++ "/" ++ show (denominator r)

decimalRatio :: Rational -> Maybe (Integer, Integer)
decimalRatio r = do
    let n = numerator r
        d = denominator r
        (c2, d') = takeFactors 2 d
        (c5, d'') = takeFactors 5 d'
    guard $ d'' == 1
    let m = if c2 > c5 then 5 ^ (c2 - c5)
                       else 2 ^ (c5 - c2)
    return (n * m, d * m)

takeFactors :: Integer -> Integer -> (Integer, Integer)
takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f)
                                    in (c+1, n')
                | otherwise = (0, n)

parseRatio :: ByteString -> Maybe Rational
parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of
                     (m:xs) | m == BC.pack "-" -> negate <$> positive xs
                     xs                        -> positive xs
    where positive = \case
              [bx] -> fromInteger . fst <$> BC.readInteger bx
              [bx, op, by] -> do
                  (x, _) <- BC.readInteger bx
                  (y, _) <- BC.readInteger by
                  case BC.unpack op of
                       "." -> return $ (x % 1) + (y % (10 ^ BC.length by))
                       "/" -> return $ x % y
                       _   -> Nothing
              _ -> Nothing