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

---
 Handler/Common.hs | 126 ++++++++++++++++++++++++++++++++----------------------
 Handler/Types.hs  |  15 +++++++
 2 files changed, 91 insertions(+), 50 deletions(-)
 create mode 100644 Handler/Types.hs

(limited to 'Handler')

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