From 0ec8e1686013bbb3613d69b9271d7c5f2afdaaf9 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Mon, 25 Dec 2023 13:25:42 +0100
Subject: chore: add library 'tags'

---
 tags/src/Tag.hs        | 41 +++++++++++++++++++++++++++++++++++++++++
 tags/src/TypedValue.hs | 33 +++++++++++++++++++++++++++++++++
 2 files changed, 74 insertions(+)
 create mode 100644 tags/src/Tag.hs
 create mode 100644 tags/src/TypedValue.hs

(limited to 'tags/src')

diff --git a/tags/src/Tag.hs b/tags/src/Tag.hs
new file mode 100644
index 0000000..ab7e171
--- /dev/null
+++ b/tags/src/Tag.hs
@@ -0,0 +1,41 @@
+module Tag
+  ( Tag (..),
+    tagKey,
+    tagValue,
+    hasTag,
+    tagValuesOf,
+  )
+where
+
+import Data.Aeson qualified as J
+import Data.Binary (Binary)
+import Data.Maybe (mapMaybe)
+import Data.Set qualified as S
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+data Tag = Tag Text (Maybe Text)
+  deriving (Show, Generic, Binary, Eq, Ord)
+
+instance J.FromJSON Tag
+
+instance J.ToJSON Tag
+
+tagKey :: Tag -> Text
+tagKey (Tag k _) = k
+
+tagValue :: Tag -> Maybe Text
+tagValue (Tag _ v) = v
+
+hasTag :: Tag -> S.Set Tag -> Bool
+hasTag tag =
+  (tagKey tag `S.member`) . S.map tagKey
+
+tagValuesOf :: Text -> [Tag] -> [Text]
+tagValuesOf key =
+  mapMaybe
+    ( \tag ->
+        if tagKey tag == key
+          then tagValue tag
+          else Nothing
+    )
diff --git a/tags/src/TypedValue.hs b/tags/src/TypedValue.hs
new file mode 100644
index 0000000..c20dce0
--- /dev/null
+++ b/tags/src/TypedValue.hs
@@ -0,0 +1,33 @@
+module TypedValue
+  ( Type (..),
+    cast,
+    castDef,
+  )
+where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Time.Calendar (Day)
+import Text.Read (readMaybe)
+
+data Type a where
+  Date :: Type Day
+  Int :: Type Int
+  String :: Type Text
+
+cast :: (forall a. Ord a => a -> a -> b) -> (Text -> Text -> Maybe b)
+cast eq x y
+  | Just x' <- castTo Date x, Just y' <- castTo Date y = Just (eq x' y')
+  | Just _ <- castTo Date x, Nothing <- castTo Date y = Nothing
+  | Just x' <- castTo Int x, Just y' <- castTo Int y = Just (eq x' y')
+  | Just _ <- castTo Int x, Nothing <- castTo Int y = Nothing
+  | otherwise = Just (eq x y)
+
+castDef :: b -> (forall a. Ord a => a -> a -> b) -> (Text -> Text -> b)
+castDef def eq x y = fromMaybe def (cast eq x y)
+
+castTo :: Type a -> Text -> Maybe a
+castTo Date = readMaybe . T.unpack
+castTo Int = readMaybe . T.unpack
+castTo String = Just
-- 
cgit v1.2.3