Fix sorting

3 files changed, 17 insertions, 3 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)])