From fe5cd6ad6c61eb13ca99acd1b69cd09b84051404 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 15 Mar 2017 14:47:31 +0100
Subject: Support types

---
 Handler/Common.hs | 43 +++++++++++++++++++++++++++++++++++++++----
 1 file changed, 39 insertions(+), 4 deletions(-)

(limited to 'Handler/Common.hs')

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 [] []
-- 
cgit v1.2.3