From 37f0dac79707a0de81ec6364d2704007eefd9289 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 15 Mar 2017 16:56:58 +0100
Subject: Fix sorting

---
 Handler/Common.hs           | 16 +++++++++++++++-
 Handler/InventoryListing.hs |  2 +-
 Handler/ReferenceListing.hs |  2 +-
 Model.hs                    | 22 +++++++++++++---------
 4 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/Handler/Common.hs b/Handler/Common.hs
index 1cf63de..65988da 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -10,13 +10,14 @@ module Handler.Common
   , ReferenceState(..)
   , FormState(..)
   , HasFormState(..)
+  , stockSort, referenceSort
   ) where
 
 import Import
 
 import Data.Unique
 
-import qualified Data.Text as Text (pack)
+import qualified Data.Text as Text
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -165,3 +166,16 @@ kinds = do
     [ [ itemKind | Entity _ Item{..} <- stock ]
     , [ referenceKind | Entity _ Reference{..} <- reference ]
     ]
+
+type Sort a = a -> a
+
+stockSort :: Sort [WithType (Entity Item)]
+stockSort = concat . map (sortOn $ entityVal . typedVal) . sortGroups . group
+  where
+    group = groupBy ((==) `on` valType) . sortOn valType
+    sortGroups = sortOn (fmap minimum . fromNullable . map (entityVal . typedVal))
+
+referenceSort :: Sort [WithType (Entity Reference)]
+referenceSort = sortBy referenceOrdering
+  where
+    referenceOrdering (Entity _ refA `WithType` refAType) (Entity _ refB `WithType` refBType) = compare refAType refBType <> compare refA refB
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
index 6d4d8fa..cbf4eab 100644
--- a/Handler/InventoryListing.hs
+++ b/Handler/InventoryListing.hs
@@ -16,7 +16,7 @@ postInventoryListingR = do
     FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
     _ -> return ()
 
-  (sortOn (entityVal . typedVal) -> stock) <- runDB $ mapM withType =<< selectList [] []
+  (stockSort -> stock) <- runDB $ mapM withType =<< selectList [] []
 
   selectRep $ do
     provideJson (stock :: [WithType (Entity Item)])
diff --git a/Handler/ReferenceListing.hs b/Handler/ReferenceListing.hs
index 0b89a20..e433429 100644
--- a/Handler/ReferenceListing.hs
+++ b/Handler/ReferenceListing.hs
@@ -17,7 +17,7 @@ postReferenceListingR = do
     FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
     _ -> return ()
 
-  reference <- runDB $ mapM withType =<< selectList [] [Asc ReferenceKind]
+  (referenceSort -> reference) <- runDB $ mapM withType =<< selectList [] [Asc ReferenceKind]
 
   selectRep $ do
     provideJson (reference :: [WithType (Entity Reference)])
diff --git a/Model.hs b/Model.hs
index a345f2f..13f18b8 100644
--- a/Model.hs
+++ b/Model.hs
@@ -45,14 +45,18 @@ withType :: ( BaseBackend backend ~ SqlBackend
 withType val = (val `WithType`) . kindType <$> getType val
 
 instance Ord Item where
-  x `compare` y = mconcat
-                  [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y)
-                  , itemOpened x `compare` itemOpened y
-                  , (isNothing $ itemExpires x) `compare` (isNothing $ itemExpires y)
-                  , itemExpires x `compare` itemExpires x
-                  , itemKind x `compare` itemKind x
-                  , itemBought x `compare` itemBought x
-                  ]
+  x `compare` y = mconcat cmprs
+    where
+      cmprs = [ itemOpened x `compareM` itemOpened y
+              , itemExpires x `compareM` itemExpires y
+              , itemKind x `compare` itemKind y
+              , itemBought x `compare` itemBought y
+              ]
+
+      compareM (Just _) Nothing = LT
+      compareM Nothing (Just _) = GT
+      compareM (Just a) (Just b) = compare a b
+      compareM _ _ = EQ
 
 instance ToJSON Item where
   toJSON Item{..} = object $
@@ -124,7 +128,7 @@ toUpdate (ItemDiffs ds) = mconcat $ do
     DiffOpened d  -> (, []) [ ItemOpened =. d ]
 
 data WithType a = WithType { typedVal :: a, valType :: Text }
-  deriving (Eq, Ord)
+  deriving (Eq, Ord, Show)
 
 typeToJSON :: ToJSON a
            => Text -- ^ Key for value, if needed
-- 
cgit v1.2.3