Support types

14 files changed, 241 insertions, 89 deletions

diff --git a/Handler/Common.hs b/Handler/Common.hs
index 2416d15..1cf63de 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -18,6 +18,9 @@ import Data.Unique
 
 import qualified Data.Text as Text (pack)
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+
 import Control.Lens
 
 import Handler.Common.Types
@@ -26,11 +29,14 @@ dayFormat :: Day -> String
 dayFormat = formatTime defaultTimeLocale "%e. %b %y"
 
 itemForm :: Maybe Item -- ^ Update existing item or insert new?
-         -> Html -> MForm Handler (FormResult Item, Widget)
+         -> Html -> MForm Handler (FormResult (WithType Item), Widget)
 itemForm proto identView = do
   today <- utctDay <$> liftIO getCurrentTime
+
+  t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto
   
   (kindRes, kindWidget) <- kindField $ itemKind <$> proto
+  (typeRes, typeWidget) <- typeField $ t
   (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
   (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
   (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"
@@ -40,13 +46,15 @@ itemForm proto identView = do
         itemBought <- boughtRes
         itemExpires <- expiresRes
         itemOpened <- openedRes
-        return Item{ itemNormKind = normalizeKind itemKind, ..}
+        t <- typeRes
+        return $ Item{ itemNormKind = normalizeKind itemKind, ..} `WithType` t
 
   return . (itemRes, ) $
     [whamlet|
             $newline never
             #{identView}
             <div .td>^{kindWidget}
+            <div .td>^{typeWidget}
             <div .td>^{boughtWidget}
             <div .td>^{expiresWidget}
             <div .td>^{openedWidget}
@@ -81,19 +89,24 @@ inventoryListing :: InventoryState -> Widget
 inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
 
 referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
-              -> Html -> MForm Handler (FormResult Reference, Widget)
+              -> Html -> MForm Handler (FormResult (WithType Reference), Widget)
 referenceForm proto identView = do
+  t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto
+
   (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
+  (typeRes, typeWidget) <- typeField $ t
 
   let referenceRes = do
         referenceKind <- kindRes
-        return Reference{ referenceNormKind = normalizeKind referenceKind, .. }
+        t <- typeRes
+        return $ Reference{ referenceNormKind = normalizeKind referenceKind, .. } `WithType` t
 
   return . (referenceRes, ) $
     [whamlet|
             $newline never
             #{identView}
             <div .td>^{kindWidget}
+            <div .td>^{typeWidget}
             |]
 
 referenceListing :: ReferenceState -> Widget
@@ -121,6 +134,28 @@ kindField proto = do
                 <option value=#{opt}>
             |]
 
+typeField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
+typeField proto = do
+  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
+
+  let
+    attrs = [ ("list", optionId)
+            , ("autocomplete", "off")
+            ]
+
+  (typeRes, typeView) <- mreq textField ("" { fsAttrs = attrs }) proto
+
+  (Set.fromList . map (kindType . entityVal) -> options) <- lift . runDB $ selectList [] []
+
+  return . (typeRes, ) $
+    [whamlet|
+            $newline never
+            ^{fvInput typeView}
+            <datalist ##{optionId}>
+              $forall opt <- Set.toList options
+                <option value=#{opt}>
+            |]
+
 kinds :: Handler [Text]
 kinds = do
   stock <- runDB $ selectList [] []
diff --git a/Handler/Common/Types.hs b/Handler/Common/Types.hs
index 08653af..9150f16 100644
--- a/Handler/Common/Types.hs
+++ b/Handler/Common/Types.hs
@@ -7,12 +7,12 @@ import Import
 import Control.Lens
 
 data InventoryState = InventoryState
-  { stock :: [Entity Item]
+  { stock :: [WithType (Entity Item)]
   , invFormState :: Maybe (FormState ItemId)
   }
 
 data ReferenceState = ReferenceState
-  { reference :: [Entity Reference]
+  { reference :: [WithType (Entity Reference)]
   , refFormState :: Maybe (FormState ReferenceId)
   }
 
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
index 12f36ba..6d4d8fa 100644
--- a/Handler/InventoryListing.hs
+++ b/Handler/InventoryListing.hs
@@ -8,19 +8,26 @@ getInventoryListingR = postInventoryListingR
 postInventoryListingR = do
   ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ itemForm Nothing
 
-  mapM_ (addMessage "formError" . toHtml) =<< case insertResult of 
-    FormSuccess newItem -> [] <$ runDB (insert newItem)
-    FormFailure errors -> return errors
-    _ -> return []
+  case insertResult of 
+    FormSuccess (Item{..} `WithType` t) -> runDB $ do
+      upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ]
+      insert Item{..}
+      return ()
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
 
-  (sortOn entityVal -> stock) <- runDB $ selectList [] []
+  (sortOn (entityVal . typedVal) -> stock) <- runDB $ mapM withType =<< selectList [] []
 
   selectRep $ do
-    provideJson (stock :: [Entity Item])
+    provideJson (stock :: [WithType (Entity Item)])
     provideRep . defaultLayout $ inventoryListing InventoryState
       { invFormState = Just InsertForm{..}
       , ..
       }
 
 putInventoryListingR :: Handler Value
-putInventoryListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item)
+putInventoryListingR = do
+  (Item{..} `WithType` t) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ]
+    withType =<< insertEntity Item{..}
diff --git a/Handler/Item.hs b/Handler/Item.hs
index 0f48261..abb1b12 100644
--- a/Handler/Item.hs
+++ b/Handler/Item.hs
@@ -4,26 +4,31 @@ import Import
 
 getItemR :: ItemId -> Handler TypedContent
 getItemR itemId = do
-  entity <- runDB $ Entity itemId <$> get404 itemId
+  entity <- runDB $ withType =<< Entity itemId <$> get404 itemId
   selectRep $ do
     provideJson entity
     provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
 
 putItemR :: ItemId -> Handler Value
 putItemR itemId = do
-  Item{..} <- requireCheckJsonBody
-  returnJson . Entity itemId =<< runDB
-    (updateGet itemId [ ItemKind =. itemKind
-                      , ItemNormKind =. itemNormKind
-                      , ItemBought =. itemBought
-                      , ItemExpires =. itemExpires
-                      , ItemOpened =. itemOpened
-                      ])
+  (Item{..} `WithType` t) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    entity <- Entity itemId <$> (updateGet itemId [ ItemKind =. itemKind
+                                                  , ItemNormKind =. itemNormKind
+                                                  , ItemBought =. itemBought
+                                                  , ItemExpires =. itemExpires
+                                                  , ItemOpened =. itemOpened
+                                                  ])
+    update (itemFkType $ entityVal entity) [ KindType =. t ]
+    withType entity
 
 patchItemR :: ItemId -> Handler Value
 patchItemR itemId = do
-  diffs <- (requireCheckJsonBody :: Handler ItemDiffs)
-  returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs)
+  (itemUpdates, typeUpdates) <- toUpdate <$> (requireCheckJsonBody :: Handler ItemDiffs)
+  returnJson <=< runDB $ do
+    entity <- Entity itemId <$> updateGet itemId itemUpdates
+    update (itemFkType $ entityVal entity) typeUpdates
+    withType entity
 
 deleteItemR :: ItemId -> Handler ()
 deleteItemR = runDB . delete
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 list = Printout
-  [ Paragraph
-    [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list 
-    ]
-  ]
+mkPrintout :: Set (WithType Text) -> Printout
+mkPrintout list = Printout ps
+  where
+    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>
-                <div .tr .sepBelow>
-                  <div .th>Item
-                $forall item <- Set.toAscList list
-                  <div .tr .color>
-                    <div .kind>#{item}
-                <form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}>
-                  <div .td>
-                    ^{printView}
-                    <button type=submit :Set.null list:disabled>
-                      Print
+              <table .main>
+                <tr .sepBelow>
+                  <th>Item
+                  <th>Type
+                $forall WithType item itemType <- Set.toAscList list
+                  <tr .color>
+                    <td .kind>#{item}
+                    <td .type>#{itemType}
+                <tr .sepAbove>
+                  <td colspan=2>
+                    <form method=post action=@{ListR} enctype=#{printEnc}>
+                      ^{printView}
+                      <button type=submit :Set.null list:disabled>
+                        Print
               |]
diff --git a/Handler/ReferenceItem.hs b/Handler/ReferenceItem.hs
index 738c9f3..44cd0a8 100644
--- a/Handler/ReferenceItem.hs
+++ b/Handler/ReferenceItem.hs
@@ -4,7 +4,7 @@ import Import
 
 getReferenceItemR :: ReferenceId -> Handler TypedContent
 getReferenceItemR referenceId = do
-  entity <- runDB $ Entity referenceId <$> get404 referenceId
+  entity <- runDB $ withType =<< Entity referenceId <$> get404 referenceId
   selectRep $ do
     provideJson entity
     provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html)
@@ -12,14 +12,13 @@ getReferenceItemR referenceId = do
 
 putReferenceItemR :: ReferenceId -> Handler Value
 putReferenceItemR referenceId = do
-  Reference{..} <- requireCheckJsonBody
-  returnJson . Entity referenceId =<< runDB
-    (updateGet referenceId [ ReferenceKind =. referenceKind
-                           , ReferenceNormKind =. referenceNormKind
-                           ])
-
-patchReferenceItemR :: ReferenceId -> Handler Value
-patchReferenceItemR = putReferenceItemR -- Just one field
+  (Reference{..} `WithType` t) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    entity <- Entity referenceId <$> updateGet referenceId [ ReferenceKind =. referenceKind
+                                                           , ReferenceNormKind =. referenceNormKind
+                                                           ]
+    update (referenceFkType $ entityVal entity) [ KindType =. t ]
+    withType entity
 
 deleteReferenceItemR :: ReferenceId -> Handler ()
 deleteReferenceItemR = runDB . delete
diff --git a/Handler/ReferenceListing.hs b/Handler/ReferenceListing.hs
index 0f777ee..0b89a20 100644
--- a/Handler/ReferenceListing.hs
+++ b/Handler/ReferenceListing.hs
@@ -9,19 +9,26 @@ getReferenceListingR = postReferenceListingR
 postReferenceListingR = do
   ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing
 
-  mapM_ (addMessage "formError" . toHtml) =<< case insertResult of 
-    FormSuccess newReference -> [] <$ runDB (insert newReference)
-    FormFailure errors -> return errors
-    _ -> return []
+  case insertResult of 
+    FormSuccess (Reference{..} `WithType` t) -> runDB $ do
+      upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind t) [ KindType =. t ]
+      insert Reference{..}
+      return ()
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
 
-  reference <- runDB $ selectList [] [Asc ReferenceKind]
+  reference <- runDB $ mapM withType =<< selectList [] [Asc ReferenceKind]
 
   selectRep $ do
-    provideJson (reference :: [Entity Reference])
+    provideJson (reference :: [WithType (Entity Reference)])
     provideRep . defaultLayout $ referenceListing ReferenceState
       { refFormState = Just InsertForm{..}
       , ..
       }
 
 putReferenceListingR :: Handler Value
-putReferenceListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Reference)
+putReferenceListingR = do
+  (Reference{..} `WithType` referenceType) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind referenceType) [ KindType =. referenceType ]
+    withType =<< insertEntity Reference{..}
diff --git a/Handler/UpdateItem.hs b/Handler/UpdateItem.hs
index a4a29c2..befbe99 100644
--- a/Handler/UpdateItem.hs
+++ b/Handler/UpdateItem.hs
@@ -11,21 +11,24 @@ postUpdateItemR fsUpdateId = do
   
   ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity
 
-  mapM_ (addMessage "formError" . toHtml) =<< case updateResult of 
-    FormSuccess Item{..} -> [] <$ runDB (update fsUpdateId [ ItemKind =. itemKind
-                                                           , ItemNormKind =. normalizeKind itemKind
-                                                           , ItemBought =. itemBought
-                                                           , ItemExpires =. itemExpires
-                                                           , ItemOpened =. itemOpened
-                                                           ])
-    FormFailure errors -> return errors
-    _ -> return []
+  case updateResult of 
+    FormSuccess (Item{..} `WithType` t) -> runDB $ do
+      upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ]
+      update fsUpdateId [ ItemKind =. itemKind
+                        , ItemNormKind =. itemNormKind
+                        , ItemBought =. itemBought
+                        , ItemExpires =. itemExpires
+                        , ItemOpened =. itemOpened
+                        ]
+      return ()
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
 
   selectRep $ do
     provideRep $ case updateResult of
       FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html
       _ -> do
-        (sortOn entityVal -> stock) <- runDB $ selectList [] []
+        (sortOn (entityVal . typedVal) -> stock) <- runDB $ mapM withType =<< selectList [] []
         defaultLayout $ inventoryListing InventoryState
           { invFormState = Just UpdateForm{..}
           , ..
diff --git a/Model.hs b/Model.hs
index 7b33f6e..a345f2f 100644
--- a/Model.hs
+++ b/Model.hs
@@ -10,7 +10,10 @@ import Control.Monad.Writer
 import           Data.Text   (Text)
 import qualified Data.Text as Text
 
+import qualified Data.HashMap.Lazy as HashMap
+
 import Data.Aeson
+import Data.Aeson.Types (Parser, Value(..))
 
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
@@ -19,6 +22,28 @@ import Data.Aeson
 share [mkPersist sqlSettings, mkMigrate "migrateAll"]
     $(persistFileWith lowerCaseSettings "config/models")
 
+class HasType a where
+  getType :: ( BaseBackend backend ~ SqlBackend
+             , MonadIO m
+             , PersistStoreRead backend
+             ) => a -> ReaderT backend m Kind
+
+instance HasType Item where
+  getType = belongsToJust itemFkType
+
+instance HasType Reference where
+  getType = belongsToJust referenceFkType
+
+instance HasType a => HasType (Entity a) where
+  getType Entity{..} = getType entityVal
+
+withType :: ( BaseBackend backend ~ SqlBackend
+            , MonadIO m
+            , PersistStoreRead backend
+            , HasType a
+            ) => a -> ReaderT backend m (WithType a)
+withType val = (val `WithType`) . kindType <$> getType val
+
 instance Ord Item where
   x `compare` y = mconcat
                   [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y)
@@ -71,6 +96,7 @@ normalizeKind :: Text -> Text
 normalizeKind = Text.strip . Text.toCaseFold
 
 data ItemDiff = DiffKind Text
+              | DiffType Text
               | DiffBought (Maybe Day)
               | DiffExpires (Maybe Day)
               | DiffOpened (Maybe Day)
@@ -80,17 +106,63 @@ newtype ItemDiffs = ItemDiffs [ItemDiff]
 instance FromJSON ItemDiffs where
   parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
     tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
+    tell =<< maybe [] (pure . DiffType) <$> lift (obj .:? "type")
     tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
     tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
     tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")
 
-toUpdate :: ItemDiffs -> [Update Item]
-toUpdate (ItemDiffs ds) = do
+toUpdate :: ItemDiffs -> ([Update Item], [Update Kind])
+toUpdate (ItemDiffs ds) = mconcat $ do
   x <- ds
-  case x of
-    DiffKind t    -> [ ItemKind =. t
-                     , ItemNormKind =. normalizeKind t
-                     ]
-    DiffBought d  -> [ ItemBought =. d ]
-    DiffExpires d -> [ ItemExpires =. d ]
-    DiffOpened d  -> [ ItemOpened =. d ]
+  return $ case x of
+    DiffKind t    -> (, []) [ ItemKind =. t
+                            , ItemNormKind =. normalizeKind t
+                            ]
+    DiffType t    -> ([], ) [ KindType =. t ]
+    DiffBought d  -> (, []) [ ItemBought =. d ]
+    DiffExpires d -> (, []) [ ItemExpires =. d ]
+    DiffOpened d  -> (, []) [ ItemOpened =. d ]
+
+data WithType a = WithType { typedVal :: a, valType :: Text }
+  deriving (Eq, Ord)
+
+typeToJSON :: ToJSON a
+           => Text -- ^ Key for value, if needed
+           -> WithType a -> Value
+typeToJSON valKey (record `WithType` t) = Object $ HashMap.insert "type" (toJSON t) o
+  where
+    o
+      | Object o' <- toJSON record = o'
+      | otherwise = HashMap.singleton valKey $ toJSON record
+
+typeFromJSON :: FromJSON a
+             => Maybe Text -- ^ Key for value, if needed
+             -> Value -> Parser (WithType a)
+typeFromJSON valKey = withObject "value with type" $ \obj -> do
+  t <- obj .: "type"
+  value <- case valKey of
+    Just key -> parseJSON =<< obj .: key
+    Nothing  -> parseJSON $ Object obj
+  return $ value `WithType` t
+
+instance ToJSON (WithType Item) where
+  toJSON = typeToJSON $ error "Item is not serializing correctly"
+
+instance ToJSON (WithType (Entity Item)) where
+  toJSON = typeToJSON $ error "Entity Item is not serializing correctly"
+
+instance ToJSON (WithType Reference) where
+  toJSON = typeToJSON "kind"
+
+instance ToJSON (WithType (Entity Reference)) where
+  toJSON ((Entity eId ref) `WithType` t) = object
+    [ "id" .= eId
+    , "type" .= t
+    , "kind" .= referenceKind ref
+    ]
+
+instance FromJSON (WithType Item) where
+  parseJSON = typeFromJSON Nothing
+
+instance FromJSON (WithType Reference) where
+  parseJSON = typeFromJSON $ Just "kind"
diff --git a/config/models b/config/models
index aa335df..16b4ce0 100644
--- a/config/models
+++ b/config/models
@@ -4,9 +4,17 @@ Item
     bought Day Maybe
     expires Day Maybe
     opened Day Maybe
+    Foreign Kind fkType normKind
     deriving Show Eq
 Reference
     normKind Text
     kind Text
+    UniqueRefKind normKind
+    Foreign Kind fkType normKind
+    deriving Show Eq Ord
+Kind
+    normKind Text
+    type Text
+    Primary normKind
     UniqueKind normKind
-    deriving Show Eq Ord
\ No newline at end of file
+    deriving Show Eq
\ No newline at end of file
diff --git a/config/routes b/config/routes
index 08babf4..6ed3204 100644
--- a/config/routes
+++ b/config/routes
@@ -7,7 +7,8 @@
 /inv/#ItemId ItemR GET PUT PATCH DELETE
 
 /ref ReferenceListingR GET POST PUT
-/ref/#ReferenceId ReferenceItemR GET PUT PATCH DELETE
+/ref/#ReferenceId ReferenceItemR GET PUT DELETE
 /ref/#ReferenceId/delete DeleteRefItemR POST
+
 /kinds KindsR GET
 /list ListR GET POST
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
index c1ccf72..bd76a01 100644
--- a/templates/default-layout.cassius
+++ b/templates/default-layout.cassius
@@ -1,20 +1,20 @@
 .main
   min-width: 20em
-.table
+.table, table
   display: table
   border-collapse: collapse
-.table div
+.table div, table td
   vertical-align: middle
-.td
+.td, td
   display: table-cell
   text-align: center
   padding: 0.25em
-.tr
+.tr, tr
   display: table-row
 .tc
   display: table-caption
   padding: 0.25em
-.th
+.th, th
   display: table-cell
   font-variant: small-caps
   font-weight: bold
@@ -26,8 +26,15 @@
   padding: 0.25em
 .kind:only-child
   text-align: center
+.type
+  display: table-cell
+  text-align: center
+  padding: 0.25em
+  color: #aaa
 .table .table .td, .table .table .tc, .table .table .th, .table .table .kind
   padding: 0
+table table td, table table th
+  padding: 0
 #messages
   list-style-type: none
   margin: 1em auto 1em 0
@@ -55,7 +62,7 @@ button
   background-color: #f0f0f0
 .color:nth-child(odd)
   background-color: #fff
-body > div
+body > div, body > table
   margin: 0 auto
 .table > h1
   display: table-caption
diff --git a/templates/inventoryListing.hamlet b/templates/inventoryListing.hamlet
index 775176d..3be43db 100644
--- a/templates/inventoryListing.hamlet
+++ b/templates/inventoryListing.hamlet
@@ -1,6 +1,7 @@
 <div .table>
   <div .tr .sepBelow>
     <div .th>Item
+    <div .th>Type
     <div .th>Bought
     <div .th>Expires
     <div .th>Opened
@@ -12,7 +13,7 @@
         <div .td>
           <button type=submit>
             Insert
-  $forall Entity itemId Item{..} <- stock
+  $forall WithType (Entity itemId Item{..}) itemType <- stock
     $if Just itemId == (preview updateId =<< formState)
       $with Just UpdateForm{..} <- formState
          <form .tr .color action=@{UpdateItemR fsUpdateId}##{toPathPiece fsUpdateId} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateId}>
@@ -23,6 +24,7 @@
     $else
       <div .tr .color ##{toPathPiece itemId}>
         <div .kind>#{itemKind}
+        <div .type>#{itemType}
         <div .td .day>
           $maybe bought <- itemBought
             #{dayFormat bought}
diff --git a/templates/referenceListing.hamlet b/templates/referenceListing.hamlet
index a76e603..414a3ec 100644
--- a/templates/referenceListing.hamlet
+++ b/templates/referenceListing.hamlet
@@ -1,6 +1,7 @@
 <div .table>
   <div .tr .sepBelow>
     <div .th>Item
+    <div .th>Type
     <div .th>Actions
   $if isJust (preview insertForm =<< formState)
     $with Just InsertForm{..} <- formState
@@ -9,9 +10,10 @@
         <div .td>
           <button type=submit>
             Insert
-  $forall Entity referenceId Reference{..} <- reference
+  $forall WithType (Entity referenceId Reference{..}) referenceType <- reference
     <div .tr .color ##{toPathPiece referenceId}>
       <div .kind>#{referenceKind}
+      <div .type>#{referenceType}
       <form .td method=post action=@{DeleteRefItemR referenceId}>
         <button type=submit>
           Delete