Category groups

src/Cache.hs

@@ -42,9 +42,9 @@ cache = unsafePerformIO STMMap.newIO
 data CacheKey
   = CacheCategoryList
   -- categories
-  | CacheCategory      (Uid Category)
+  | CacheCategory       (Uid Category)
-  | CacheCategoryTitle (Uid Category)
+  | CacheCategoryHeader (Uid Category)
-  | CacheCategoryNotes (Uid Category)
+  | CacheCategoryNotes  (Uid Category)
   -- items
   | CacheItem            (Uid Item)
   | CacheItemInfo        (Uid Item)
@@ -58,10 +58,10 @@ instance Hashable CacheKey
 
 cacheDepends :: GlobalState -> CacheKey -> [CacheKey]
 cacheDepends gs key = case key of
-  CacheCategoryList    -> [key]
+  CacheCategoryList     -> [key]
-  CacheCategory _      -> [key, CacheCategoryList]
+  CacheCategory _       -> [key, CacheCategoryList]
-  CacheCategoryTitle x -> [key, CacheCategory x, CacheCategoryList]
+  CacheCategoryHeader x -> [key, CacheCategory x, CacheCategoryList]
-  CacheCategoryNotes x -> [key, CacheCategory x, CacheCategoryList]
+  CacheCategoryNotes x  -> [key, CacheCategory x, CacheCategoryList]
   -- If the item's group has been changed, it can influence how other items
   -- in the same category are rendered (specifically, their lists of groups
   -- in iteminfo will change)

src/JS.hs

@@ -56,7 +56,8 @@ allJSFunctions = JS . T.unlines . map fromJS $ [
   addCategoryAndRedirect, addItem,
   addPro, addCon,
   -- Set methods
-  submitCategoryTitle, submitItemDescription, submitCategoryNotes,
+  submitCategoryTitle, submitCategoryGroup, submitCategoryNotes,
+  submitItemDescription,
   submitItemInfo, submitItemNotes, submitItemEcosystem,
   submitTrait,
   -- Other things
@@ -452,6 +453,14 @@ submitCategoryTitle =
      .done(replaceWithData(node));
   |]
 
+submitCategoryGroup :: JSFunction a => a
+submitCategoryGroup =
+  makeJSFunction "submitCategoryGroup" ["node", "catId", "s"]
+  [text|
+    $.post("/haskell/set/category/"+catId+"/group", {content: s})
+     .done(replaceWithData(node));
+  |]
+
 submitCategoryNotes :: JSFunction a => a
 submitCategoryNotes =
   makeJSFunction "submitCategoryNotes" ["node", "catId", "s"]

src/Main.hs

@@ -171,6 +171,7 @@ invalidateCacheForEdit ed = do
     Edit'AddPro itemId _ _             -> [CacheItem itemId]
     Edit'AddCon itemId _ _             -> [CacheItem itemId]
     Edit'SetCategoryTitle catId _ _    -> [CacheCategory catId]
+    Edit'SetCategoryGroup catId _ _    -> [CacheCategory catId]
     Edit'SetCategoryNotes catId _ _    -> [CacheCategory catId]
     Edit'SetItemName itemId _ _        -> [CacheItem itemId]
     Edit'SetItemLink itemId _ _        -> [CacheItem itemId]
@@ -212,6 +213,11 @@ undoEdit (Edit'SetCategoryTitle catId old new) = do
   if now /= new
     then return (Left "title has been changed further")
     else Right () <$ dbUpdate (SetCategoryTitle catId old)
+undoEdit (Edit'SetCategoryGroup catId old new) = do
+  now <- view group_ <$> dbQuery (GetCategory catId)
+  if now /= new
+    then return (Left "group has been changed further")
+    else Right () <$ dbUpdate (SetCategoryGroup catId old)
 undoEdit (Edit'SetCategoryNotes catId old new) = do
   now <- view (notes.mdText) <$> dbQuery (GetCategory catId)
   if now /= new
@@ -270,10 +276,10 @@ undoEdit (Edit'MoveTrait itemId traitId direction) = do
 
 renderMethods :: SpockM () () ServerState ()
 renderMethods = Spock.subcomponent "render" $ do
-  -- Title of a category
+  -- Header of a category
-  Spock.get (categoryVar <//> "title") $ \catId -> do
+  Spock.get (categoryVar <//> "header") $ \catId -> do
     category <- dbQuery (GetCategory catId)
-    lucidIO $ renderCategoryTitle category
+    lucidIO $ renderCategoryHeader category
   -- Notes for a category
   Spock.get (categoryVar <//> "notes") $ \catId -> do
     category <- dbQuery (GetCategory catId)
@@ -309,10 +315,17 @@ setMethods = Spock.subcomponent "set" $ do
   -- Title of a category
   Spock.post (categoryVar <//> "title") $ \catId -> do
     content' <- param' "content"
-    invalidateCache' (CacheCategoryTitle catId)
+    invalidateCache' (CacheCategoryHeader catId)
     (edit, category) <- dbUpdate (SetCategoryTitle catId content')
     addEdit edit
-    lucidIO $ renderCategoryTitle category
+    lucidIO $ renderCategoryHeader category
+  -- Group of a category
+  Spock.post (categoryVar <//> "group") $ \catId -> do
+    content' <- param' "content"
+    invalidateCache' (CacheCategoryHeader catId)
+    (edit, category) <- dbUpdate (SetCategoryGroup catId content')
+    addEdit edit
+    lucidIO $ renderCategoryHeader category
   -- Notes for a category
   Spock.post (categoryVar <//> "notes") $ \catId -> do
     content' <- param' "content"

src/Types.hs

@@ -22,7 +22,6 @@ module Types
   ItemKind(..),
     hackageName,
   Item(..),
-    group_,
     pros,
     prosDeleted,
     cons,
@@ -54,6 +53,7 @@ module Types
   description,
   notes,
   created,
+  group_,
 
   -- * Edits
   Edit(..),
@@ -79,6 +79,7 @@ module Types
   SetGlobalState(..),
   -- *** 'Category'
   SetCategoryTitle(..),
+  SetCategoryGroup(..),
   SetCategoryNotes(..),
   -- *** 'Item'
   SetItemName(..),
@@ -137,6 +138,61 @@ import Utils
 import Markdown
 
 
+{- Note [extending types]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Here's what you should do if you add a new field to 'Trait', 'Item', or 'Category'.
+
+
+Types.hs
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  1. Fix all warnings about uninitialised fields that might appear (by e.g. providing a default value).
+
+  2. Update the migration code; see Note [acid-state]. (Usually updating the migration code means simply copying and pasting the old version of the type and adding “_n” to all fields, where ‘n’ is ‘previous n’ + 1.)
+
+  3. If the field is user-editable: add a new constructor to 'Edit' and update the migration code for 'Edit'. Update 'isVacuousEdit', too.
+
+  4. Create a method for updating the field (setSomethingField), add it to the “makeAcidic ''GlobalState” declaration, and export the SetSomethingField type.
+
+  5. Export a lens for the field (if it shares the name with some other field, move it to the “* Overloaded things” heading).
+
+
+Cache.hs
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  1. If the field is non-trivial (e.g. “notes”) and it makes sense to cache it, add it to 'CacheKey'.
+
+  2. Update 'cacheDepends'.
+
+
+JS.hs
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  1. If the field is user-editable, add a method for setting it and don't forget to add it to the 'allJSFunctions' list.
+
+
+View.hs
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  1. If the field is non-trivial, add a method for rendering it.
+
+  2. Don't forget to actually render it if the user is supposed to see it.
+
+  3. Add a branch for the constructor you made in Types.hs/#3 to 'renderEdit'.
+
+
+Main.hs
+~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  1. Add a case to 'invalidateCacheForEdit'.
+
+  2. Add a case to 'undoEdit'.
+
+  3. If the field is user-editable, add a method for changing it to 'setMethods'.
+
+-}
+
 data Trait = Trait {
   _traitUid :: Uid Trait,
   _traitContent :: MarkdownInline }
@@ -311,6 +367,7 @@ hueToLightColor (Hue i) = table !! ((i-1) `mod` length table)
 data Category = Category {
   _categoryUid :: Uid Category,
   _categoryTitle :: Text,
+  _categoryGroup_ :: Text,
   _categoryCreated :: UTCTime,
   _categoryNotes :: MarkdownBlock,
   _categoryGroups :: Map Text Hue,
@@ -318,7 +375,7 @@ data Category = Category {
   _categoryItemsDeleted :: [Item] }
   deriving (Show)
 
-deriveSafeCopySimple 4 'extension ''Category
+deriveSafeCopySimple 5 'extension ''Category
 makeFields ''Category
 
 categorySlug :: Category -> Text
@@ -328,28 +385,28 @@ categorySlug category =
 -- Old version, needed for safe migration. It can most likely be already
 -- deleted (if a checkpoint has been created), but it's been left here as a
 -- template for future migrations.
-data Category_v3 = Category_v3 {
+data Category_v4 = Category_v4 {
-  _categoryUid_v3 :: Uid Category,
+  _categoryUid_v4 :: Uid Category,
-  _categoryTitle_v3 :: Text,
+  _categoryTitle_v4 :: Text,
-  _categoryCreated_v3 :: UTCTime,
+  _categoryCreated_v4 :: UTCTime,
-  _categoryNotes_v3 :: MarkdownBlock,
+  _categoryNotes_v4 :: MarkdownBlock,
-  _categoryGroups_v3 :: Map Text Hue,
+  _categoryGroups_v4 :: Map Text Hue,
-  _categoryItems_v3 :: [Item],
+  _categoryItems_v4 :: [Item],
-  _categoryItemsDeleted_v3 :: [Item] }
+  _categoryItemsDeleted_v4 :: [Item] }
 
--- TODO: at the next migration change this to deriveSafeCopySimple!
+deriveSafeCopySimple 4 'base ''Category_v4
-deriveSafeCopy 3 'base ''Category_v3
 
 instance Migrate Category where
-  type MigrateFrom Category = Category_v3
+  type MigrateFrom Category = Category_v4
-  migrate Category_v3{..} = Category {
+  migrate Category_v4{..} = Category {
-    _categoryUid = _categoryUid_v3,
+    _categoryUid = _categoryUid_v4,
-    _categoryTitle = _categoryTitle_v3,
+    _categoryTitle = _categoryTitle_v4,
-    _categoryCreated = _categoryCreated_v3,
+    _categoryGroup_ = "Miscellaneous",
-    _categoryNotes = _categoryNotes_v3,
+    _categoryCreated = _categoryCreated_v4,
-    _categoryGroups = _categoryGroups_v3,
+    _categoryNotes = _categoryNotes_v4,
-    _categoryItems = _categoryItems_v3,
+    _categoryGroups = _categoryGroups_v4,
-    _categoryItemsDeleted = _categoryItemsDeleted_v3 }
+    _categoryItems = _categoryItems_v4,
+    _categoryItemsDeleted = _categoryItemsDeleted_v4 }
 
 -- Edits
 
@@ -377,6 +434,10 @@ data Edit
       editCategoryUid      :: Uid Category,
       editCategoryTitle    :: Text,
       editCategoryNewTitle :: Text }
+  | Edit'SetCategoryGroup {
+      editCategoryUid      :: Uid Category,
+      editCategoryGroup    :: Text,
+      editCategoryNewGroup :: Text }
   | Edit'SetCategoryNotes {
       editCategoryUid      :: Uid Category,
       editCategoryNotes    :: Text,
@@ -442,9 +503,9 @@ data Edit
 
   deriving (Eq, Show)
 
-deriveSafeCopySimple 2 'extension ''Edit
+deriveSafeCopySimple 3 'extension ''Edit
 
-genVer ''Edit 1 [
+genVer ''Edit 2 [
   -- Add
   Copy 'Edit'AddCategory,
   Copy 'Edit'AddItem,
@@ -471,12 +532,11 @@ genVer ''Edit 1 [
   Copy 'Edit'MoveItem,
   Copy 'Edit'MoveTrait ]
 
--- TODO: at the next migration change this to deriveSafeCopySimple!
+deriveSafeCopySimple 2 'base ''Edit_v2
-deriveSafeCopy 1 'base ''Edit_v1
 
 instance Migrate Edit where
-  type MigrateFrom Edit = Edit_v1
+  type MigrateFrom Edit = Edit_v2
-  migrate = $(migrateVer ''Edit 1 [
+  migrate = $(migrateVer ''Edit 2 [
     CopyM 'Edit'AddCategory,
     CopyM 'Edit'AddItem,
     CopyM 'Edit'AddPro,
@@ -508,6 +568,8 @@ instance Migrate Edit where
 isVacuousEdit :: Edit -> Bool
 isVacuousEdit Edit'SetCategoryTitle{..} =
   editCategoryTitle == editCategoryNewTitle
+isVacuousEdit Edit'SetCategoryGroup{..} =
+  editCategoryGroup == editCategoryNewGroup
 isVacuousEdit Edit'SetCategoryNotes{..} =
   editCategoryNotes == editCategoryNewNotes
 isVacuousEdit Edit'SetItemName{..} =
@@ -662,6 +724,7 @@ addCategory catId title' created' = do
   let newCategory = Category {
         _categoryUid = catId,
         _categoryTitle = title',
+        _categoryGroup_ = "Miscellaneous",
         _categoryCreated = created',
         _categoryNotes = renderMarkdownBlock "",
         _categoryGroups = mempty,
@@ -736,6 +799,12 @@ setCategoryTitle catId title' = do
   let edit = Edit'SetCategoryTitle catId oldTitle title'
   (edit,) <$> use (categoryById catId)
 
+setCategoryGroup :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
+setCategoryGroup catId group' = do
+  oldGroup <- categoryById catId . group_ <<.= group'
+  let edit = Edit'SetCategoryGroup catId oldGroup group'
+  (edit,) <$> use (categoryById catId)
+
 setCategoryNotes :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
 setCategoryNotes catId notes' = do
   oldNotes <- categoryById catId . notes <<.= renderMarkdownBlock notes'
@@ -1050,7 +1119,7 @@ makeAcidic ''GlobalState [
   'addPro, 'addCon,
   -- set
   'setGlobalState,
-  'setCategoryTitle, 'setCategoryNotes,
+  'setCategoryTitle, 'setCategoryGroup, 'setCategoryNotes,
   'setItemName, 'setItemLink, 'setItemGroup, 'setItemKind,
     'setItemDescription, 'setItemNotes, 'setItemEcosystem,
   'setTraitContent,

src/View.hs

@@ -19,6 +19,7 @@ module View
   renderDonate,
   renderCategoryPage,
   renderUnwrittenRules,
+  renderSearchResults,
 
   -- * Tracking
   renderTracking,
@@ -28,7 +29,7 @@ module View
   -- ** Categories
   renderCategoryList,
   renderCategory,
-  renderCategoryTitle,
+  renderCategoryHeader,
   renderCategoryNotes,
   -- ** Items
   renderItem,
@@ -279,6 +280,10 @@ renderEdit globalState edit = do
     Edit'SetCategoryTitle _catId oldTitle newTitle -> p_ $ do
       "changed title of category " >> quote (toHtml oldTitle)
       " to " >> quote (toHtml newTitle)
+    Edit'SetCategoryGroup catId oldGroup newGroup -> p_ $ do
+      "changed group of category " >> printCategory catId
+      " from " >> quote (toHtml oldGroup)
+      " to "   >> quote (toHtml newGroup)
     Edit'SetCategoryNotes catId oldNotes newNotes -> do
       p_ $ "changed notes of category " >> printCategory catId
       table_ $ tr_ $ do
@@ -378,7 +383,7 @@ renderHaskellRoot globalState mbSearchQuery =
               | otherwise       = filter ((/= 0) . rank) .
                                   reverse . sortOn rank
                                     $ globalState^.categories
-        renderCategoryList rankedCategories
+        renderSearchResults rankedCategories
     -- TODO: maybe add a button like “give me random category that is
     -- unfinished”
 
@@ -537,6 +542,18 @@ helpVersion = 3
 -- 'Cache.invalidateCache'.
 renderCategoryList :: (MonadIO m, MonadRandom m) => [Category] -> HtmlT m ()
 renderCategoryList cats = cached CacheCategoryList $ do
+  div_ [id_ "categories"] $
+    for_ (groupWith (view group_) cats) $ \gr ->
+      div_ [class_ "category-group"] $ do
+        h2_ $ toHtml (gr^?!_head.group_)
+        for gr $ \category -> do
+          -- TODO: this link shouldn't be absolute [absolute-links]
+          a_ [href_ ("/haskell/" <> categorySlug category)] $
+            toHtml (category^.title)
+          br_ []
+
+renderSearchResults :: Monad m => [Category] -> HtmlT m ()
+renderSearchResults cats = do
   div_ [id_ "categories"] $
     for_ cats $ \category -> do
       -- TODO: this link shouldn't be absolute [absolute-links]
@@ -544,8 +561,8 @@ renderCategoryList cats = cached CacheCategoryList $ do
         toHtml (category^.title)
       br_ []
 
-renderCategoryTitle :: MonadIO m => Category -> HtmlT m ()
+renderCategoryHeader :: MonadIO m => Category -> HtmlT m ()
-renderCategoryTitle category = cached (CacheCategoryTitle (category^.uid)) $ do
+renderCategoryHeader category = cached (CacheCategoryHeader (category^.uid)) $ do
   let thisId = "category-title-" <> uidToText (category^.uid)
       this   = JS.selectId thisId
   h2_ [id_ thisId, class_ "category-title"] $ do
@@ -560,6 +577,9 @@ renderCategoryTitle category = cached (CacheCategoryTitle (category^.uid)) $ do
       a_ [href_ ("/haskell/" <> categorySlug category)] $
         toHtml (category^.title)
       emptySpan "1em"
+      span_ [class_ "group"] $
+        toHtml (category^.group_)
+      emptySpan "1em"
       textButton "edit" $
         JS.switchSection (this, "editing" :: Text)
       emptySpan "1em"
@@ -572,6 +592,13 @@ renderCategoryTitle category = cached (CacheCategoryTitle (category^.uid)) $ do
         autocomplete_ "off",
         onEnter $
           JS.submitCategoryTitle (this, category^.uid, inputValue)]
+      emptySpan "0.5em"
+      textInput [
+        class_ "group",
+        value_ (category^.group_),
+        autocomplete_ "off",
+        onEnter $
+          JS.submitCategoryGroup (this, category^.uid, inputValue)]
       emptySpan "1em"
       textButton "cancel" $
         JS.switchSection (this, "normal" :: Text)
@@ -604,7 +631,7 @@ renderCategoryNotes category = cached (CacheCategoryNotes (category^.uid)) $ do
 renderCategory :: (MonadIO m, MonadRandom m) => Category -> HtmlT m ()
 renderCategory category = cached (CacheCategory (category^.uid)) $ do
   div_ [class_ "category", id_ (categoryNodeId category)] $ do
-    renderCategoryTitle category
+    renderCategoryHeader category
     renderCategoryNotes category
     itemsNode <- div_ [class_ "items"] $ do
       mapM_ (renderItem category) (category^.items)

static/css.css

@@ -47,12 +47,18 @@ body {
   width: 100%; }
 
 #categories {
+  display: flex;
+  flex-flow: row wrap;
+  justify-content: space-between;
   margin-top: 1em; }
 
-#categories > a {
+#categories a {
   font-weight: bold;
-  line-height: 130%;
+  line-height: 100%;
-  font-size: 150%; }
+  font-size: 110%; }
+
+.category-group {
+  min-width: 350px; }
 
 .category {
   margin-top: 3em; }
@@ -78,6 +84,11 @@ body {
   opacity: 0.3;
   height: 20px; }
 
+.category-title .group {
+  font-size: 60%;
+  font-weight: normal;
+  color: gray; }
+
 .item-traits, .item-notes, .item-description, .item-ecosystem {
   padding: 10px 15px 20px 15px; }