Only show lists of categories

Fixes #8

src/JS.hs

@@ -9,6 +9,8 @@ NoImplicitPrelude
 
 
 -- TODO: try to make it more type-safe somehow?
+
+-- TODO: maybe use jmacro or something?
 module JS where
 
 
@@ -51,7 +53,7 @@ allJSFunctions = JS . T.unlines . map fromJS $ [
   makeTraitEditor,
   makeItemNotesEditor,
   -- Add methods
-  addCategory, addItem,
+  addCategoryAndRedirect, addItem,
   addPro, addCon,
   -- Set methods
   submitCategoryTitle, submitItemDescription, submitCategoryNotes,
@@ -396,13 +398,16 @@ makeItemNotesEditor =
       "Markdown", $(space), monospaceLabel);
   |]
 
--- | Create a new category.
-addCategory :: JSFunction a => a
-addCategory =
-  makeJSFunction "addCategory" ["node", "s"]
+-- | Create a new category and redirect to it (or redirect to an old category
+-- if it exists already).
+addCategoryAndRedirect :: JSFunction a => a
+addCategoryAndRedirect =
+  makeJSFunction "addCategoryAndRedirect" ["s"]
   [text|
     $.post("/haskell/add/category", {content: s})
-     .done(prependData(node));
+     .done(function (url) {
+        window.location.href = url;
+      });
   |]
 
 -- | Add a new item to some category.

src/Main.hs

@@ -347,11 +347,19 @@ addMethods = Spock.subcomponent "add" $ do
   -- New category
   Spock.post "category" $ do
     title' <- param' "content"
-    catId <- randomShortUid
-    time <- liftIO getCurrentTime
-    (edit, newCategory) <- dbUpdate (AddCategory catId title' time)
-    addEdit edit
-    lucidIO $ renderCategory newCategory
+    -- If the category exists already, don't create it
+    cats <- view categories <$> dbQuery GetGlobalState
+    category <- case find ((== title') . view title) cats of
+      Just c  -> return c
+      Nothing -> do
+        catId <- randomShortUid
+        time <- liftIO getCurrentTime
+        (edit, newCategory) <- dbUpdate (AddCategory catId title' time)
+        addEdit edit
+        return newCategory
+    -- And now send the URL of the new (or old) category
+    Spock.text ("/haskell/" <> categorySlug category)
+
   -- New item in a category
   Spock.post (categoryVar <//> "item") $ \catId -> do
     name' <- param' "name"

src/View.hs

@@ -365,8 +365,7 @@ renderHaskellRoot globalState mbSearchQuery =
     textInput [
       placeholder_ "add a category",
       autocomplete_ "off",
-      onEnter $ JS.addCategory (JS.selectId "categories", inputValue) <>
-                clearInput ]
+      onEnter $ JS.addCategoryAndRedirect [inputValue] ]
     case mbSearchQuery of
       Nothing -> renderCategoryList (globalState^.categories)
       Just query' -> do
@@ -538,7 +537,11 @@ helpVersion = 3
 renderCategoryList :: (MonadIO m, MonadRandom m) => [Category] -> HtmlT m ()
 renderCategoryList cats =
   div_ [id_ "categories"] $
-    mapM_ renderCategory cats
+    for_ cats $ \category -> do
+      -- TODO: this link shouldn't be absolute [absolute-links]
+      a_ [href_ ("/haskell/" <> categorySlug category)] $
+        toHtml (category^.title)
+      br_ []
 
 renderCategoryTitle :: Monad m => Category -> HtmlT m ()
 renderCategoryTitle category = do