From ab9f65916c81fd82f05befc0679c45fe05f26531 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Tue, 17 Oct 2023 11:56:11 +0200
Subject: make sort type-aware

---
 anissue.cabal           |  1 +
 app/Issue/Filter.hs     | 23 ++---------------------
 app/Issue/Sort.hs       | 32 ++++++++++++++++++++++----------
 app/Issue/TypedValue.hs | 33 +++++++++++++++++++++++++++++++++
 4 files changed, 58 insertions(+), 31 deletions(-)
 create mode 100644 app/Issue/TypedValue.hs

diff --git a/anissue.cabal b/anissue.cabal
index 732a5e4..f2e62cb 100644
--- a/anissue.cabal
+++ b/anissue.cabal
@@ -74,6 +74,7 @@ executable anissue
       Issue.Sort
       Issue.Tag
       Issue.Text
+      Issue.TypedValue
       Parallel
       Process
       TreeGrepper.FileType
diff --git a/app/Issue/Filter.hs b/app/Issue/Filter.hs
index c30a8e2..7501e35 100644
--- a/app/Issue/Filter.hs
+++ b/app/Issue/Filter.hs
@@ -9,11 +9,10 @@ import Control.Applicative (liftA2, (<|>))
 import Data.Attoparsec.Text qualified as A
 import Data.Text (Text)
 import Data.Text qualified as T
-import Data.Time.Calendar (Day)
 import Issue (Issue (..))
 import Issue.Tag (tagKey, tagValue)
+import Issue.TypedValue (castDef)
 import Options.Applicative qualified as O
-import Text.Read (readMaybe)
 
 -- TODO Revise filter negation
 --
@@ -121,7 +120,7 @@ simpleFilterPredicate (ByTag k v) i = any ((&&) <$> matchKey <*> matchValue) (i.
     matchKey = (==) k . tagKey
     matchValue t =
       case (v, tagValue t) of
-        (Just (o, v'), Just w') -> cast (op o) v' w'
+        (Just (o, v'), Just w') -> castDef False (op o) v' w'
         (Just _, Nothing) -> False
         (Nothing, _) -> True
 
@@ -131,21 +130,3 @@ op (Ge) = flip (>=)
 op (Gt) = flip (>)
 op (Le) = flip (<=)
 op (Lt) = flip (<)
-
-data Type a where
-  Date :: Type Day
-  Int :: Type Int
-  String :: Type Text
-
-cast :: (forall a. Ord a => a -> a -> Bool) -> (Text -> Text -> Bool)
-cast eq x y
-  | Just x' <- castTo Date x, Just y' <- castTo Date y = eq x' y'
-  | Just _ <- castTo Date x, Nothing <- castTo Date y = False
-  | Just x' <- castTo Int x, Just y' <- castTo Int y = eq x' y'
-  | Just _ <- castTo Int x, Nothing <- castTo Int y = False
-  | otherwise = eq x y
-
-castTo :: Type a -> Text -> Maybe a
-castTo Date = readMaybe . T.unpack
-castTo Int = readMaybe . T.unpack
-castTo String = Just
diff --git a/app/Issue/Sort.hs b/app/Issue/Sort.hs
index 46f4a19..5499f9c 100644
--- a/app/Issue/Sort.hs
+++ b/app/Issue/Sort.hs
@@ -8,12 +8,12 @@ module Issue.Sort
 where
 
 import Data.List (sort, sortBy)
-import Data.Maybe (mapMaybe)
-import Data.Ord (comparing)
+import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Issue (Issue (..))
 import Issue.Tag (Tag (..))
+import Issue.TypedValue (cast)
 import Options.Applicative qualified as O
 
 data Sort = Sort Order SortBy
@@ -57,12 +57,24 @@ applySorts cs = compose (defaultSort : cs)
     toSort :: Sort -> ([Issue] -> [Issue])
     toSort (Sort order sortBy') =
       (if order == Desc then reverse else id)
-        . sortBy (comparing (applySortBy sortBy'))
+        . sortBy (sortByCompare sortBy')
 
-applySortBy :: SortBy -> Issue -> [Text]
-applySortBy (SortByTag k) i =
-  sort
-    ( mapMaybe
-        (\(Tag k' v) -> if k' == k then v else Nothing)
-        (i.tags ++ i.internalTags)
-    )
+sortByCompare :: SortBy -> (Issue -> Issue -> Ordering)
+sortByCompare (SortByTag k) i1 i2 =
+  compareList
+    (incomparableFirst (cast compare))
+    (sort $ tagValues k (i1.tags ++ i1.internalTags))
+    (sort $ tagValues k (i2.tags ++ i2.internalTags))
+
+tagValues :: Text -> [Tag] -> [Text]
+tagValues k = mapMaybe (\(Tag k' v) -> if k' == k then v else Nothing)
+
+compareList :: (a -> a -> Ordering) -> ([a] -> [a] -> Ordering)
+compareList _ [] _ = LT
+compareList _ _ [] = GT
+compareList g (a : as) (b : bs)
+  | g a b == EQ = compareList g as bs
+  | otherwise = g a b
+
+incomparableFirst :: (a -> a -> Maybe Ordering) -> (a -> a -> Ordering)
+incomparableFirst cmp a b = fromMaybe LT (cmp a b)
diff --git a/app/Issue/TypedValue.hs b/app/Issue/TypedValue.hs
new file mode 100644
index 0000000..9af04bb
--- /dev/null
+++ b/app/Issue/TypedValue.hs
@@ -0,0 +1,33 @@
+module Issue.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