From 3cd4169e33c07b71129aafcecfb81a3b5007fa39 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 15 Mar 2017 18:11:47 +0100
Subject: Autocomplete types

---
 Application.hs    |   1 +
 Handler/Common.hs | 126 ++++++++++++++++++++++++++++++++----------------------
 Handler/Types.hs  |  15 +++++++
 Settings.hs       |   2 +-
 bar.cabal         |   1 +
 config/routes     |   3 ++
 6 files changed, 97 insertions(+), 51 deletions(-)
 create mode 100644 Handler/Types.hs

diff --git a/Application.hs b/Application.hs
index 85ceb2f..3a16e88 100644
--- a/Application.hs
+++ b/Application.hs
@@ -41,6 +41,7 @@ import Handler.ReferenceListing
 import Handler.ReferenceItem
 import Handler.DeleteRefItem
 import Handler.Kinds
+import Handler.Types
 import Handler.List
 
 -- This line actually creates our YesodDispatch instance. It is the second half
diff --git a/Handler/Common.hs b/Handler/Common.hs
index 65988da..a1ae34b 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -26,6 +26,8 @@ import Control.Lens
 
 import Handler.Common.Types
 
+import Text.Julius (RawJS(..))
+
 dayFormat :: Day -> String
 dayFormat = formatTime defaultTimeLocale "%e. %b %y"
 
@@ -36,8 +38,12 @@ itemForm proto identView = do
 
   t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto
   
-  (kindRes, kindWidget) <- kindField $ itemKind <$> proto
-  (typeRes, typeWidget) <- typeField $ t
+  let kt kWidget tWidget =
+        [whamlet|
+                <div .td>^{kWidget}
+                <div .td>^{tWidget}
+                |]
+  ((kindRes, typeRes), typedKindWidget) <- typedKindField kt ((itemKind <$> proto), 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"
@@ -54,8 +60,7 @@ itemForm proto identView = do
     [whamlet|
             $newline never
             #{identView}
-            <div .td>^{kindWidget}
-            <div .td>^{typeWidget}
+            ^{typedKindWidget}
             <div .td>^{boughtWidget}
             <div .td>^{expiresWidget}
             <div .td>^{openedWidget}
@@ -93,9 +98,14 @@ referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
               -> Html -> MForm Handler (FormResult (WithType Reference), Widget)
 referenceForm proto identView = do
   t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto
+  
+  let kt kWidget tWidget =
+        [whamlet|
+                <div .td>^{kWidget}
+                <div .td>^{tWidget}
+                |]
 
-  (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
-  (typeRes, typeWidget) <- typeField $ t
+  ((kindRes, typeRes), typedKindWidget) <- typedKindField kt ((referenceKind <$> proto), t)
 
   let referenceRes = do
         referenceKind <- kindRes
@@ -106,63 +116,79 @@ referenceForm proto identView = do
     [whamlet|
             $newline never
             #{identView}
-            <div .td>^{kindWidget}
-            <div .td>^{typeWidget}
+            ^{typedKindWidget}
             |]
 
 referenceListing :: ReferenceState -> Widget
 referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing")
 
-kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
-kindField proto = do
-  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
-
+typedKindField :: (Widget -> Widget -> Widget) -- ^ `\kindWidget typeWidget -> _`
+               -> (Maybe Text, Maybe Text) -- ^ `(kindProto, typeProto)`
+               -> MForm Handler ((FormResult Text, FormResult Text), Widget) -- ^ `((kindRes, typeRes), typedKindWidget)`
+typedKindField collate (kindProto, typeProto) = do
+  tOptionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
   let
-    attrs = [ ("list", optionId)
-            , ("autocomplete", "off")
-            ]
-  
-  (kindRes, kindView) <- mreq textField ("" { fsAttrs = attrs }) proto
-
-  options <- lift kinds
-
-  return . (kindRes, ) $
-    [whamlet|
-            $newline never
-            ^{fvInput kindView}
-            <datalist ##{optionId}>
-              $forall opt <- options
-                <option value=#{opt}>
-            |]
-
-typeField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
-typeField proto = do
-  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
+    tAttrs = [ ("list", tOptionId)
+             , ("autocomplete", "off")
+             ]
+  kOptionId <- ("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}>
-            |]
+    kAttrs = [ ("list", kOptionId)
+             , ("autocomplete", "off")
+             ]
+
+  (kindRes, kindView) <- mreq textField ("" { fsAttrs = kAttrs }) kindProto
+  (typeRes, typeView) <- mreq textField ("" { fsAttrs = tAttrs }) typeProto
+
+  kOptions <- lift kinds
+  (Set.fromList . map (kindType . entityVal) -> tOptions) <- lift . runDB $ selectList [] []
+
+  return . ((kindRes, typeRes), ) $ do
+    toWidget $
+      [julius|
+             $(function () {
+               $("##{rawJS $ fvId kindView}").change(function () {
+                 $.ajax({
+                   url: '@{TypeR}',
+                   type: 'GET',
+                   contentType: 'application/json',
+                   data: {
+                     kind: $(this).val()
+                   },
+                   success: function (answer) {
+                     $("##{rawJS $ fvId typeView}").val(answer);
+                    typeChanged = false;
+                    }
+                 });
+               }) ;
+             });
+             |]
+    let
+      kindWidget =
+        [whamlet|
+                $newline never
+                ^{fvInput kindView}
+                <datalist ##{kOptionId}>
+                  $forall opt <- kOptions
+                    <option value=#{opt}>
+                |]
+      typeWidget =
+        [whamlet|
+                $newline never
+                ^{fvInput typeView}
+                <datalist ##{tOptionId}>
+                  $forall opt <- tOptions
+                    <option value=#{opt}>
+                |]
+    collate kindWidget typeWidget
 
-kinds :: Handler [Text]
+kinds :: Handler (Set Text)
 kinds = do
   stock <- runDB $ selectList [] []
   reference <- runDB $ selectList [] []
 
-  return $ concat
+  return . Set.fromList $ concat
     [ [ itemKind | Entity _ Item{..} <- stock ]
     , [ referenceKind | Entity _ Reference{..} <- reference ]
     ]
diff --git a/Handler/Types.hs b/Handler/Types.hs
new file mode 100644
index 0000000..04055ad
--- /dev/null
+++ b/Handler/Types.hs
@@ -0,0 +1,15 @@
+module Handler.Types where
+
+import Import
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+getTypesR :: Handler Value
+getTypesR = returnJson <=< runDB $ do
+  Set.fromList . map (kindType . entityVal) <$> selectList [] []
+
+getTypeR :: Handler Value
+getTypeR = do
+  kind <- maybe (invalidArgs ["kind"]) return =<< lookupGetParam "kind"
+  returnJson <=< runDB $ kindType . entityVal <$> getBy404 (UniqueKind $ normalizeKind kind)
diff --git a/Settings.hs b/Settings.hs
index d0e16ea..a15fb03 100644
--- a/Settings.hs
+++ b/Settings.hs
@@ -19,7 +19,7 @@ import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
 import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
                                     widgetFileReload)
 
-import Thermoprint.Client (BaseUrl(..), Scheme(..), InvalidBaseUrlException, parseBaseUrl)
+import Thermoprint.Client (BaseUrl(..), parseBaseUrl)
 
 #ifdef DEVELOPMENT
 #define DEV_BOOL True
diff --git a/bar.cabal b/bar.cabal
index 1d25e21..112a89d 100644
--- a/bar.cabal
+++ b/bar.cabal
@@ -31,6 +31,7 @@ library
                      Handler.ReferenceItem
                      Handler.DeleteRefItem
                      Handler.Kinds
+                     Handler.Types
                      Handler.List
 
     if flag(dev) || flag(library-only)
diff --git a/config/routes b/config/routes
index 6ed3204..5024ab1 100644
--- a/config/routes
+++ b/config/routes
@@ -11,4 +11,7 @@
 /ref/#ReferenceId/delete DeleteRefItemR POST
 
 /kinds KindsR GET
+/types TypesR GET
+/type TypeR GET
+
 /list ListR GET POST
-- 
cgit v1.2.3