1 files changed, 24 insertions, 20 deletions
diff --git a/Handler/List.hs b/Handler/List.hs
index cfd3f7c..70f323a 100644
--- a/Handler/List.hs
+++ b/Handler/List.hs
@@ -18,17 +18,18 @@ import Database.Persist.Sql (Single(..), rawSql)
 import Thermoprint.Client
-list :: Handler (Set Text)
+list :: Handler (Set (WithType Text))
 list = do
-  (map unSingle -> kinds) <- runDB $ rawSql "select reference.kind from reference where not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind)) " []
+  (map (uncurry WithType . bimap unSingle unSingle) -> kinds) <- runDB $ rawSql "select reference.kind, kind.type from reference,kind where (not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind))) and (reference.norm_kind = kind.norm_kind)" []
  return $ Set.fromList kinds
-mkPrintout :: Set Text -> Printout
+mkPrintout :: Set (WithType Text) -> Printout
-mkPrintout list = Printout
+mkPrintout list = Printout ps
-  [ Paragraph
+  where
-    [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list 
+    ps = Map.foldMapWithKey (fmap (pure . Paragraph . pure . Cooked) . toLines) $ group list
-    ]
+    group = Map.fromListWith (<>) . fmap (\(kind `WithType` t) -> (t, Set.singleton kind)) . Set.toAscList
-  ]
+    toLines t (Set.toAscList -> kinds) = either id Line . text . Lazy.Text.fromStrict . Text.unlines $
+      pure t ++ map (" - " <>) kinds
 getListR, postListR :: Handler TypedContent
 getListR = postListR
@@ -54,18 +55,21 @@ postListR = do
    _ -> return ()
  
  selectRep $ do
-    provideJson list
+    provideJson $ typeToJSON "item" <$> Set.toAscList list
    provideRep . defaultLayout $
      [whamlet|
-              <div .table .main>
+              <table .main>
-                <div .tr .sepBelow>
+                <tr .sepBelow>
-                  <div .th>Item
+                  <th>Item
-                $forall item <- Set.toAscList list
+                  <th>Type
-                  <div .tr .color>
+                $forall WithType item itemType <- Set.toAscList list
-                    <div .kind>#{item}
+                  <tr .color>
-                <form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}>
+                    <td .kind>#{item}
-                  <div .td>
+                    <td .type>#{itemType}
-                    ^{printView}
+                <tr .sepAbove>
-                    <button type=submit :Set.null list:disabled>
+                  <td colspan=2>
-                      Print
+                    <form method=post action=@{ListR} enctype=#{printEnc}>
+                      ^{printView}
+                      <button type=submit :Set.null list:disabled>
+                        Print
              |]

diff --git a/Handler/List.hs b/Handler/List.hs index cfd3f7c..70f323a 100644 --- a/Handler/List.hs +++ b/Handler/List.hs
@@ -18,17 +18,18 @@ import Database.Persist.Sql (Single(..), rawSql)
18		18
19	import Thermoprint.Client	19	import Thermoprint.Client
20		20
21	list :: Handler (Set Text)	21	list :: Handler (Set (WithType Text))
22	list = do	22	list = do
23	(map unSingle -> kinds) <- runDB $ rawSql "select reference.kind from reference where not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind)) " []	23	(map (uncurry WithType . bimap unSingle unSingle) -> kinds) <- runDB $ rawSql "select reference.kind, kind.type from reference,kind where (not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind))) and (reference.norm_kind = kind.norm_kind)" []
24	return $ Set.fromList kinds	24	return $ Set.fromList kinds
25		25
26	mkPrintout :: Set Text -> Printout	26	mkPrintout :: Set (WithType Text) -> Printout
27	mkPrintout list = Printout	27	mkPrintout list = Printout ps
28	[ Paragraph	28	where
29	[Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list	29	ps = Map.foldMapWithKey (fmap (pure . Paragraph . pure . Cooked) . toLines) $ group list
30	]	30	group = Map.fromListWith (<>) . fmap (\(kind `WithType` t) -> (t, Set.singleton kind)) . Set.toAscList
31	]	31	toLines t (Set.toAscList -> kinds) = either id Line . text . Lazy.Text.fromStrict . Text.unlines $
		32	pure t ++ map (" - " <>) kinds
32		33
33	getListR, postListR :: Handler TypedContent	34	getListR, postListR :: Handler TypedContent
34	getListR = postListR	35	getListR = postListR
@@ -54,18 +55,21 @@ postListR = do
54	_ -> return ()	55	_ -> return ()
55		56
56	selectRep $ do	57	selectRep $ do
57	provideJson list	58	provideJson $ typeToJSON "item" <$> Set.toAscList list
58	provideRep . defaultLayout $	59	provideRep . defaultLayout $
59	[whamlet\|	60	[whamlet\|
60	<div .table .main>	61	<table .main>
61	<div .tr .sepBelow>	62	<tr .sepBelow>
62	<div .th>Item	63	<th>Item
63	$forall item <- Set.toAscList list	64	<th>Type
64	<div .tr .color>	65	$forall WithType item itemType <- Set.toAscList list
65	<div .kind>#{item}	66	<tr .color>
66	<form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}>	67	<td .kind>#{item}
67	<div .td>	68	<td .type>#{itemType}
68	^{printView}	69	<tr .sepAbove>
69	<button type=submit :Set.null list:disabled>	70	<td colspan=2>
70	Print	71	<form method=post action=@{ListR} enctype=#{printEnc}>
		72	^{printView}
		73	<button type=submit :Set.null list:disabled>
		74	Print
71	\|]	75	\|]