From 55e4f8e861945cf9d32420cac612ebe5a9218f89 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 28 Jan 2023 21:25:30 +0100
Subject: Empty record item type

---
 src/Storage.hs | 30 +++++++++++++++++++++++++-----
 1 file changed, 25 insertions(+), 5 deletions(-)

(limited to 'src/Storage.hs')

diff --git a/src/Storage.hs b/src/Storage.hs
index 6dd7cdf..47477df 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -29,14 +29,14 @@ module Storage (
     StorableText(..), StorableDate(..), StorableUUID(..),
 
     storeBlob, storeRec, storeZero,
-    storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeJson, storeRef, storeRawRef,
-    storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbJson, storeMbRef, storeMbRawRef,
+    storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeJson, storeRef, storeRawRef,
+    storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbJson, storeMbRef, storeMbRawRef,
     storeZRef,
 
     LoadRec,
     loadBlob, loadRec, loadZero,
-    loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadJson, loadRef, loadRawRef,
-    loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbJson, loadMbRef, loadMbRawRef,
+    loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadJson, loadRef, loadRawRef,
+    loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbJson, loadMbRef, loadMbRawRef,
     loadTexts, loadBinaries, loadRefs, loadRawRefs,
     loadZRef,
 
@@ -182,6 +182,7 @@ copyObject' _ (Blob bs) = return $ return $ Blob bs
 copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs
     where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c'))
           copyItem (n, item) = fmap (n,) <$> case item of
+              RecEmpty -> return $ return $ RecEmpty
               RecInt x -> return $ return $ RecInt x
               RecNum x -> return $ return $ RecNum x
               RecText x -> return $ return $ RecText x
@@ -215,7 +216,8 @@ type Object = Object' Complete
 type PartialObject = Object' Partial
 
 data RecItem' c
-    = RecInt Integer
+    = RecEmpty
+    | RecInt Integer
     | RecNum Rational
     | RecText Text
     | RecBinary ByteString
@@ -246,6 +248,7 @@ storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef
 storeRawBytes = unsafeStoreRawBytes
 
 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']
@@ -310,6 +313,8 @@ unsafeDeserializeObject st bytes =
                   content = B.drop (space+1) line
 
               val <- 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
@@ -627,6 +632,12 @@ instance StorableUUID UUID where
     toUUID = id; fromUUID = id
 
 
+storeEmpty :: String -> StoreRec c
+storeEmpty name = 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 = tell [return [(BC.pack name, RecInt $ toInteger x)]]
 
@@ -714,6 +725,15 @@ loadZero x = asks snd >>= \case
     _          -> throwError "Expecting zero"
 
 
+loadEmpty :: String -> LoadRec ()
+loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name
+
+loadMbEmpty :: String -> LoadRec (Maybe ())
+loadMbEmpty name = asks (lookup (BC.pack name) . snd) >>= \case
+    Nothing -> return Nothing
+    Just (RecEmpty) -> return (Just ())
+    Just _ -> throwError $ "Expecting type int of record item '"++name++"'"
+
 loadInt :: Num a => String -> LoadRec a
 loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name
 
-- 
cgit v1.2.3