diff options
Diffstat (limited to 'Handler')
| -rw-r--r-- | Handler/Common.hs | 3 | ||||
| -rw-r--r-- | Handler/Common/Types.hs | 2 | ||||
| -rw-r--r-- | Handler/List.hs | 29 |
3 files changed, 22 insertions, 12 deletions
diff --git a/Handler/Common.hs b/Handler/Common.hs index 88cbd8d..11a9431 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs | |||
| @@ -1,4 +1,5 @@ | |||
| 1 | {-# LANGUAGE ApplicativeDo #-} | 1 | {-# LANGUAGE ApplicativeDo |
| 2 | #-} | ||
| 2 | 3 | ||
| 3 | module Handler.Common | 4 | module Handler.Common |
| 4 | ( inventoryListing | 5 | ( inventoryListing |
diff --git a/Handler/Common/Types.hs b/Handler/Common/Types.hs index 9150f16..491468c 100644 --- a/Handler/Common/Types.hs +++ b/Handler/Common/Types.hs | |||
| @@ -1,5 +1,3 @@ | |||
| 1 | {-# LANGUAGE FunctionalDependencies #-} | ||
| 2 | |||
| 3 | module Handler.Common.Types where | 1 | module Handler.Common.Types where |
| 4 | 2 | ||
| 5 | import Import | 3 | import Import |
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 | |||
| 3 | module Handler.List where | 1 | module Handler.List where |
| 4 | 2 | ||
| 5 | import Import | 3 | import Import |
| @@ -12,8 +10,18 @@ import qualified Data.Map as Map | |||
| 12 | import qualified Data.Text as Text | 10 | import qualified Data.Text as Text |
| 13 | import qualified Data.Text.Lazy as Lazy.Text | 11 | import qualified Data.Text.Lazy as Lazy.Text |
| 14 | 12 | ||
| 13 | #ifdef THERMOPRINT | ||
| 15 | import Thermoprint.Client | 14 | import Thermoprint.Client |
| 16 | 15 | ||
| 16 | mkPrintout :: Set (WithType Text) -> Printout | ||
| 17 | mkPrintout 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 | |||
| 17 | list :: Handler (Set (WithType Text)) | 25 | list :: Handler (Set (WithType Text)) |
| 18 | list = runDB $ do | 26 | list = 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 | ||
| 37 | mkPrintout :: Set (WithType Text) -> Printout | ||
| 38 | mkPrintout 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 | ||
| 45 | getListR, postListR :: Handler TypedContent | 47 | getListR, postListR :: Handler TypedContent |
| 46 | getListR = postListR | 48 | getListR = postListR |
| 47 | postListR = do | 49 | postListR = 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 | ||
| 105 | getListR, postListR :: Handler TypedContent | ||
| 106 | getListR = postListR | ||
| 107 | postListR = do | ||
| 108 | list <- list | ||
| 109 | selectRep $ do | ||
| 110 | provideJson $ typeToJSON "item" <$> Set.toAscList list | ||
| 111 | provideRep $ defaultLayout $(widgetFile "list-no-thermoprint") | ||
| 112 | #endif | ||
