summaryrefslogtreecommitdiff
path: root/Handler/List.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Handler/List.hs')
-rw-r--r--Handler/List.hs29
1 files changed, 20 insertions, 9 deletions
diff --git a/Handler/List.hs b/Handler/List.hs
index 522f6f5..a2194ba 100644
--- a/Handler/List.hs
+++ b/Handler/List.hs
@@ -1,5 +1,3 @@
1{-# LANGUAGE PatternGuards #-}
2
3module Handler.List where 1module Handler.List where
4 2
5import Import 3import Import
@@ -12,8 +10,18 @@ import qualified Data.Map as Map
12import qualified Data.Text as Text 10import qualified Data.Text as Text
13import qualified Data.Text.Lazy as Lazy.Text 11import qualified Data.Text.Lazy as Lazy.Text
14 12
13#ifdef THERMOPRINT
15import Thermoprint.Client 14import Thermoprint.Client
16 15
16mkPrintout :: Set (WithType Text) -> Printout
17mkPrintout list = Printout ps
18 where
19 ps = Map.foldMapWithKey (fmap (pure . Paragraph . pure . Cooked) . toLines) $ group list
20 group = Map.fromListWith (<>) . fmap (\(kind `WithType` t) -> (t, Set.singleton kind)) . Set.toAscList
21 toLines t (Set.toAscList -> kinds) = either id Line . text . Lazy.Text.fromStrict . Text.unlines $
22 pure t ++ map (" - " <>) kinds
23#endif
24
17list :: Handler (Set (WithType Text)) 25list :: Handler (Set (WithType Text))
18list = runDB $ do 26list = runDB $ do
19 today <- liftIO $ utctDay <$> getCurrentTime 27 today <- liftIO $ utctDay <$> getCurrentTime
@@ -34,14 +42,8 @@ list = runDB $ do
34 42
35 return $ Set.map (fmap referenceKind) references' 43 return $ Set.map (fmap referenceKind) references'
36 44
37mkPrintout :: Set (WithType Text) -> Printout
38mkPrintout list = Printout ps
39 where
40 ps = Map.foldMapWithKey (fmap (pure . Paragraph . pure . Cooked) . toLines) $ group list
41 group = Map.fromListWith (<>) . fmap (\(kind `WithType` t) -> (t, Set.singleton kind)) . Set.toAscList
42 toLines t (Set.toAscList -> kinds) = either id Line . text . Lazy.Text.fromStrict . Text.unlines $
43 pure t ++ map (" - " <>) kinds
44 45
46#ifdef THERMOPRINT
45getListR, postListR :: Handler TypedContent 47getListR, postListR :: Handler TypedContent
46getListR = postListR 48getListR = postListR
47postListR = do 49postListR = do
@@ -99,3 +101,12 @@ postListR = do
99 selectRep $ do 101 selectRep $ do
100 provideJson $ typeToJSON "item" <$> Set.toAscList list 102 provideJson $ typeToJSON "item" <$> Set.toAscList list
101 provideRep $ defaultLayout $(widgetFile "list") 103 provideRep $ defaultLayout $(widgetFile "list")
104#else
105getListR, postListR :: Handler TypedContent
106getListR = postListR
107postListR = do
108 list <- list
109 selectRep $ do
110 provideJson $ typeToJSON "item" <$> Set.toAscList list
111 provideRep $ defaultLayout $(widgetFile "list-no-thermoprint")
112#endif