diff --git a/src/Cache.hs b/src/Cache.hs index 1ebe922..9f78387 100644 --- a/src/Cache.hs +++ b/src/Cache.hs @@ -42,9 +42,9 @@ cache = unsafePerformIO STMMap.newIO data CacheKey = CacheCategoryList -- categories - | CacheCategory (Uid Category) - | CacheCategoryTitle (Uid Category) - | CacheCategoryNotes (Uid Category) + | CacheCategory (Uid Category) + | CacheCategoryHeader (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] - CacheCategory _ -> [key, CacheCategoryList] - CacheCategoryTitle x -> [key, CacheCategory x, CacheCategoryList] - CacheCategoryNotes x -> [key, CacheCategory x, CacheCategoryList] + CacheCategoryList -> [key] + CacheCategory _ -> [key, CacheCategoryList] + CacheCategoryHeader 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) diff --git a/src/JS.hs b/src/JS.hs index 1a94e93..b6b7f23 100644 --- a/src/JS.hs +++ b/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"] diff --git a/src/Main.hs b/src/Main.hs index ab1bbec..5015cbe 100644 --- a/src/Main.hs +++ b/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 - Spock.get (categoryVar "title") $ \catId -> do + -- Header of a category + 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" diff --git a/src/Types.hs b/src/Types.hs index 07089b7..7893e3d 100644 --- a/src/Types.hs +++ b/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 { - _categoryUid_v3 :: Uid Category, - _categoryTitle_v3 :: Text, - _categoryCreated_v3 :: UTCTime, - _categoryNotes_v3 :: MarkdownBlock, - _categoryGroups_v3 :: Map Text Hue, - _categoryItems_v3 :: [Item], - _categoryItemsDeleted_v3 :: [Item] } +data Category_v4 = Category_v4 { + _categoryUid_v4 :: Uid Category, + _categoryTitle_v4 :: Text, + _categoryCreated_v4 :: UTCTime, + _categoryNotes_v4 :: MarkdownBlock, + _categoryGroups_v4 :: Map Text Hue, + _categoryItems_v4 :: [Item], + _categoryItemsDeleted_v4 :: [Item] } --- TODO: at the next migration change this to deriveSafeCopySimple! -deriveSafeCopy 3 'base ''Category_v3 +deriveSafeCopySimple 4 'base ''Category_v4 instance Migrate Category where - type MigrateFrom Category = Category_v3 - migrate Category_v3{..} = Category { - _categoryUid = _categoryUid_v3, - _categoryTitle = _categoryTitle_v3, - _categoryCreated = _categoryCreated_v3, - _categoryNotes = _categoryNotes_v3, - _categoryGroups = _categoryGroups_v3, - _categoryItems = _categoryItems_v3, - _categoryItemsDeleted = _categoryItemsDeleted_v3 } + type MigrateFrom Category = Category_v4 + migrate Category_v4{..} = Category { + _categoryUid = _categoryUid_v4, + _categoryTitle = _categoryTitle_v4, + _categoryGroup_ = "Miscellaneous", + _categoryCreated = _categoryCreated_v4, + _categoryNotes = _categoryNotes_v4, + _categoryGroups = _categoryGroups_v4, + _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! -deriveSafeCopy 1 'base ''Edit_v1 +deriveSafeCopySimple 2 'base ''Edit_v2 instance Migrate Edit where - type MigrateFrom Edit = Edit_v1 - migrate = $(migrateVer ''Edit 1 [ + type MigrateFrom Edit = Edit_v2 + 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, diff --git a/src/View.hs b/src/View.hs index ef7fe5f..c8b0489 100644 --- a/src/View.hs +++ b/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 () -renderCategoryTitle category = cached (CacheCategoryTitle (category^.uid)) $ do +renderCategoryHeader :: MonadIO m => Category -> HtmlT m () +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) diff --git a/static/css.css b/static/css.css index 41eb687..31bb70e 100644 --- a/static/css.css +++ b/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%; - font-size: 150%; } + line-height: 100%; + 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; }