diff --git a/hslibs.cabal b/hslibs.cabal index 2b83e91..7d70ec7 100644 --- a/hslibs.cabal +++ b/hslibs.cabal @@ -33,6 +33,7 @@ executable hslibs , base-prelude , blaze-html >= 0.8.1.1 , cheapskate + , containers >= 0.5 , lucid , microlens-platform >= 0.2.3 , mtl diff --git a/src/JS.hs b/src/JS.hs index c8f8e88..b1ed32e 100644 --- a/src/JS.hs +++ b/src/JS.hs @@ -306,10 +306,25 @@ submitTrait = submitItemInfo :: JSFunction a => a submitItemInfo = - makeJSFunction "submitItemInfo" ["node", "itemId", "form"] + makeJSFunction "submitItemInfo" ["infoNode", "traitsNode", "itemId", "form"] [text| + // If the group was changed, we need to recolor the whole item, + // but we don't want to rerender the item on the server because + // it would lose the item's state (e.g. what if the traits were + // being edited? etc). So, instead we query colors from the server + // and change the color of the “traits” div manually. $.post("/set/item/"+itemId+"/info", $(form).serialize()) - .done(replaceWithData(node)); + .done(function (data) { + // Note the order – first we change the color, then we replace + // the info node. The reason is that otherwise the traitsNode + // selector might become invalid (if it depends on the infoNode + // selector). + $.get("/render/item/"+itemId+"/colors") + .done(function (colors) { + $(traitsNode).css("background-color", colors.light); + replaceWithData(infoNode)(data); + }); + }); |] moveTraitUp :: JSFunction a => a diff --git a/src/Main.hs b/src/Main.hs index 1a7c472..ed015e7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,6 +9,7 @@ ScopedTypeVariables, FunctionalDependencies, TypeFamilies, DataKinds, +MultiWayIf, NoImplicitPrelude #-} @@ -22,6 +23,9 @@ import BasePrelude hiding (Category) import Control.Monad.State -- Lenses import Lens.Micro.Platform +-- Containers +import qualified Data.Map as M +import Data.Map (Map) -- Text import Data.Text (Text) import qualified Data.Text as T @@ -30,7 +34,7 @@ import NeatInterpolation import System.Random -- Web import Lucid hiding (for_) -import Web.Spock hiding (get, text) +import Web.Spock hiding (head, get, text) import qualified Web.Spock as Spock import Network.Wai.Middleware.Static import Web.PathPieces @@ -43,6 +47,8 @@ import Utils -- | Unique id, used for many things – categories, items, and anchor ids. -- Note that in HTML 5 using numeric ids for divs, spans, etc is okay. +-- +-- TODO: use Text? type Uid = Int randomUid :: MonadIO m => m Uid @@ -65,12 +71,13 @@ hackageLibrary = Library True makeFields ''ItemKind data Item = Item { - _itemUid :: Uid, - _itemName :: Text, - _itemPros :: [Trait], - _itemCons :: [Trait], - _itemLink :: Maybe Url, - _itemKind :: ItemKind } + _itemUid :: Uid, + _itemName :: Text, + _itemGroup_ :: Maybe Text, + _itemPros :: [Trait], + _itemCons :: [Trait], + _itemLink :: Maybe Url, + _itemKind :: ItemKind } makeFields ''Item @@ -79,14 +86,80 @@ traitById uid' = singular $ (pros.each . filtered ((== uid') . view uid)) `failing` (cons.each . filtered ((== uid') . view uid)) +data Hue = NoHue | Hue Int + deriving (Eq, Ord) + +instance Show Hue where + show NoHue = "0" + show (Hue n) = show n + +{- +https://www.google.com/design/spec/style/color.html#color-color-palette + + 50 100 200 + ------ ------ ------ +red : FFEBEE FFCDD2 EF9A9A +pink : FCE4EC F8BBD0 F48FB1 +purple : F3E5F5 E1BEE7 CE93D8 +deep purple : EDE7F6 D1C4E9 B39DDB +indigo : E8EAF6 C5CAE9 9FA8DA +blue : E3F2FD BBDEFB 90CAF9 +light blue : E1F5FE B3E5FC 81D4FA +cyan : E0F7FA B2EBF2 80DEEA +teal : E0F2F1 B2DFDB 80CBC4 +green : E8F5E9 C8E6C9 A5D6A7 +light green : F1F8E9 DCEDC8 C5E1A5 +lime : F9FBE7 F0F4C3 E6EE9C +yellow : FFFDE7 FFF9C4 FFF59D +amber : FFF8E1 FFECB3 FFE082 +orange : FFF3E0 FFE0B2 FFCC80 +deep orange : FBE9E7 FFCCBC FFAB91 +brown : EFEBE9 D7CCC8 BCAAA4 +gray : FAFAFA F5F5F5 EEEEEE +blue gray : ECEFF1 CFD8DC B0BEC5 +-} + +-- TODO: more colors and don't repeat them! +-- TODO: what about colorblind people? +-- TODO: check how all colors look (not just deep purple) +hueToDarkColor :: Hue -> Text +hueToDarkColor NoHue = "#D6D6D6" -- the color for gray isn't from Google's + -- palette, since their “100” is too light +hueToDarkColor (Hue i) = table !! ((i-1) `mod` length table) + where + -- the “100” colors + table = ["#D1C4E9", -- deep purple + "#C8E6C9", -- green + "#FFECB3", -- amber + "#FFCDD2"] -- red + +hueToLightColor :: Hue -> Text +hueToLightColor NoHue = "#F0F0F0" -- the color for gray isn't from Google's + -- palette, since their “50” is too light +hueToLightColor (Hue i) = table !! ((i-1) `mod` length table) + where + -- the “50” colors + table = ["#EDE7F6", + "#E8F5E9", + "#FFF8E1", + "#FFEBEE"] + data Category = Category { _categoryUid :: Uid, _categoryTitle :: Text, _categoryNotes :: Text, + _categoryGroups :: Map Text Hue, _categoryItems :: [Item] } makeFields ''Category +addGroupIfDoesNotExist :: Text -> Map Text Hue -> Map Text Hue +addGroupIfDoesNotExist g gs + | M.member g gs = gs + | otherwise = M.insert g firstNotTaken gs + where + firstNotTaken = head $ map Hue [1..] \\ M.elems gs + data GlobalState = GlobalState { _categories :: [Category] } @@ -115,6 +188,7 @@ sampleState = do let lensItem = Item { _itemUid = 12, _itemName = "lens", + _itemGroup_ = Nothing, _itemPros = [Trait 121 "The most widely used lenses library, by a \ \huge margin.", Trait 123 "Contains pretty much everything you could \ @@ -148,6 +222,7 @@ sampleState = do let microlensItem = Item { _itemUid = 13, _itemName = "microlens", + _itemGroup_ = Nothing, _itemPros = [Trait 131 "Very small (the base package has no \ \dependencies at all, and features like \ \Template Haskell lens generation or \ @@ -164,11 +239,13 @@ sampleState = do _categoryUid = 1, _categoryTitle = "Lenses", _categoryNotes = "Lenses are first-class composable accessors.", + _categoryGroups = mempty, _categoryItems = [lensItem, microlensItem] } let parsecItem = Item { _itemUid = 21, _itemName = "parsec", + _itemGroup_ = Just "parsec-like", _itemPros = [Trait 211 "the most widely used package", Trait 213 "has lots of tutorials, book coverage, etc"], _itemCons = [Trait 212 "development has stagnated"], @@ -177,6 +254,7 @@ sampleState = do let megaparsecItem = Item { _itemUid = 22, _itemName = "megaparsec", + _itemGroup_ = Nothing, _itemPros = [Trait 221 "the API is largely similar to Parsec, \ \so existing tutorials/code samples \ \could be reused and migration is easy"], @@ -186,6 +264,7 @@ sampleState = do let attoparsecItem = Item { _itemUid = 23, _itemName = "attoparsec", + _itemGroup_ = Nothing, _itemPros = [Trait 231 "very fast, good for parsing binary formats"], _itemCons = [Trait 232 "can't report positions of parsing errors", Trait 234 "doesn't provide a monad transformer"], @@ -195,9 +274,55 @@ sampleState = do _categoryUid = 2, _categoryTitle = "Parsing", _categoryNotes = "Parsers are parsers.", + _categoryGroups = M.fromList [("parsec-like", Hue 1)], _categoryItems = [parsecItem, megaparsecItem, attoparsecItem] } - GlobalState {_categories = [lensesCategory, parsingCategory]} + -- As many different groups as there are different hues + let def = Item { + _itemUid = undefined, + _itemName = undefined, + _itemGroup_ = Nothing, + _itemPros = [], + _itemCons = [], + _itemLink = Nothing, + _itemKind = hackageLibrary } + let item1 = def { + _itemUid = 31, + _itemName = "api-builder", + _itemGroup_ = Just "group 1" } + let item2 = def { + _itemUid = 32, + _itemName = "aeson", + _itemGroup_ = Just "group 2" } + let item3 = def { + _itemUid = 33, + _itemName = "unordered-containers", + _itemGroup_ = Just "group 1" } + let item4 = def { + _itemUid = 34, + _itemName = "lens", + _itemGroup_ = Just "group 3" } + let item5 = def { + _itemUid = 35, + _itemName = "bytestring", + _itemGroup_ = Just "group 4" } + let item6 = def { + _itemUid = 36, + _itemName = "microlens", + _itemGroup_ = Nothing } + let item7 = def { + _itemUid = 37, + _itemName = "parsec", + _itemGroup_ = Nothing } + let huesCategory = Category { + _categoryUid = 3, + _categoryTitle = "Testing hues", + _categoryNotes = "Hopefully they all look good.", + _categoryGroups = + M.fromList [("group " <> tshow i, Hue i) | i <- [1..4]], + _categoryItems = [item1, item2, item3, item4, item5, item6, item7] } + + GlobalState {_categories = [lensesCategory, parsingCategory, huesCategory]} itemVar :: Path '[Uid] itemVar = "item" var @@ -230,16 +355,25 @@ renderMethods = Spock.subcomponent "render" $ do category <- withGlobal $ use (categoryById catId) renderMode <- param' "mode" lucid $ renderCategoryNotes renderMode category + -- Item colors + Spock.get (itemVar "colors") $ \itemId -> do + item <- withGlobal $ use (itemById itemId) + category <- withGlobal $ use (categoryByItem itemId) + let hue = getItemHue category item + json $ M.fromList [("light" :: Text, hueToLightColor hue), + ("dark" :: Text, hueToDarkColor hue)] -- Item info Spock.get (itemVar "info") $ \itemId -> do item <- withGlobal $ use (itemById itemId) renderMode <- param' "mode" - lucid $ renderItemInfo renderMode item + cat <- withGlobal $ use (categoryByItem itemId) + lucid $ renderItemInfo renderMode cat item -- All item traits Spock.get (itemVar "traits") $ \itemId -> do item <- withGlobal $ use (itemById itemId) renderMode <- param' "mode" - lucid $ renderItemTraits renderMode item + cat <- withGlobal $ use (categoryByItem itemId) + lucid $ renderItemTraits renderMode cat item -- A single trait Spock.get (itemVar traitVar) $ \itemId traitId -> do trait <- withGlobal $ use (itemById itemId . traitById traitId) @@ -264,12 +398,47 @@ setMethods = Spock.subcomponent "set" $ do lucid $ renderCategoryNotes Editable changedCategory -- Item info Spock.post (itemVar "info") $ \itemId -> do + -- TODO: rename to “itemLens” and “categoryLens”? + let category :: Lens' GlobalState Category + category = categoryByItem itemId + let item :: Lens' GlobalState Item + item = itemById itemId + -- TODO: add a jumpy note saying where the form is handled + -- and other notes saying where stuff is rendered, etc name' <- T.strip <$> param' "name" link' <- T.strip <$> param' "link" onHackage' <- (== Just ("on" :: Text)) <$> param "on-hackage" + group' <- do + groupField <- param' "group" + customGroupField <- param' "custom-group" + if | groupField == "-" -> return Nothing + | groupField == newGroupValue -> return (Just customGroupField) + | otherwise -> return (Just groupField) + -- If the group is a new one (entered in the “custom group” field), add + -- it to the list of groups in the category (which would cause a new hue + -- to be generated) + case group' of + Nothing -> return () + Just x -> withGlobal $ category.groups %= addGroupIfDoesNotExist x + -- Update list of groups if the group removed was the last of its kind. + -- Note that this should be done after adding a new group because we also + -- want the color to change. If the item was the only item in its group, + -- then the sequence of actions would be as follows: + -- + -- * new group is added (and hence new color is assigned) + -- * old group is deleted (and now the old color is unused) + withGlobal $ do + oldGroup <- use (item.group_) + case oldGroup of + Nothing -> return () + Just g -> when (oldGroup /= group') $ do + allItems <- use (category.items) + let inSameGroup item' = item'^.group_ == Just g + isUnique = length (filter inSameGroup allItems) == 1 + when isUnique $ + category.groups %= M.delete g + -- Modify the item changedItem <- withGlobal $ do - let item :: Lens' GlobalState Item - item = itemById itemId -- TODO: actually validate the form and report errors unless (T.null name') $ item.name .= name' @@ -278,8 +447,10 @@ setMethods = Spock.subcomponent "set" $ do (_, Just l) -> item.link .= Just l _otherwise -> return () item.kind.onHackage .= onHackage' + item.group_ .= group' use item - lucid $ renderItemInfo Editable changedItem + cat <- withGlobal $ use category + lucid $ renderItemInfo Editable cat changedItem -- Trait Spock.post (itemVar traitVar) $ \itemId traitId -> do content' <- param' "content" @@ -298,24 +469,27 @@ addMethods = Spock.subcomponent "add" $ do _categoryUid = uid', _categoryTitle = content', _categoryNotes = "(write some notes here, describe the category, etc)", + _categoryGroups = mempty, _categoryItems = [] } withGlobal $ categories %= (newCategory :) lucid $ renderCategory newCategory -- New library in a category Spock.post (categoryVar "library") $ \catId -> do - name' <- param' "name" - uid' <- randomUid + itemName <- param' "name" + itemId <- randomUid let newItem = Item { - _itemUid = uid', - _itemName = name', - _itemPros = [], - _itemCons = [], - _itemLink = Nothing, - _itemKind = hackageLibrary } + _itemUid = itemId, + _itemName = itemName, + _itemGroup_ = Nothing, + _itemPros = [], + _itemCons = [], + _itemLink = Nothing, + _itemKind = hackageLibrary } -- TODO: maybe do something if the category doesn't exist (e.g. has been -- already deleted) withGlobal $ categoryById catId . items %= (++ [newItem]) - lucid $ renderItem Editable newItem + cat <- withGlobal $ use (categoryByItem itemId) + lucid $ renderItem Editable cat newItem -- Pro (argument in favor of a library) Spock.post (itemVar "pro") $ \itemId -> do content' <- param' "content" @@ -519,7 +693,7 @@ renderCategory category = renderCategoryTitle Editable category renderCategoryNotes Editable category itemsNode <- div_ [class_ "items"] $ do - mapM_ (renderItem Normal) (category^.items) + mapM_ (renderItem Normal category) (category^.items) thisNode textInput [placeholder_ "add an item"] $ JS.addLibrary (itemsNode, category^.uid, inputValue) <> clearInput @@ -527,14 +701,15 @@ renderCategory category = -- TODO: add arrows for moving items up and down in category, and something -- to delete an item – those things could be at the left side, like on Reddit --- TODO: allow colors for grouping (e.g. van Laarhoven lens libraries go one --- way, other libraries go another way) (and provide a legend under the --- category) (and sort by colors) +getItemHue :: Category -> Item -> Hue +getItemHue category item = case item^.group_ of + Nothing -> NoHue + Just s -> M.findWithDefault NoHue s (category^.groups) -- TODO: perhaps use jQuery Touch Punch or something to allow dragging items -- instead of using arrows? Touch Punch works on mobile, too -renderItem :: Editable -> Item -> HtmlT IO () -renderItem editable item = +renderItem :: Editable -> Category -> Item -> HtmlT IO () +renderItem editable cat item = div_ [class_ "item"] $ do itemNode <- thisNode -- TODO: the controls and item-info should be aligned (currently the @@ -555,40 +730,50 @@ renderItem editable item = -- This div is needed for “display:flex” on the outer div to work (which -- makes item-controls be placed to the left of everything else) div_ [style_ "width:100%"] $ do - renderItemInfo Editable item + renderItemInfo Editable cat item case editable of Normal -> do - renderItemTraits Normal item + renderItemTraits Normal cat item Editable -> do - renderItemTraits Editable item + renderItemTraits Editable cat item + +-- TODO: find some way to give all functions access to category and item (or +-- category, item and trait) without passing everything explicitly? -- TODO: warn when a library isn't on Hackage but is supposed to be -- TODO: give a link to oldest available docs when the new docs aren't there -renderItemInfo :: Editable -> Item -> HtmlT IO () -renderItemInfo editable item = - div_ [class_ "item-info"] $ do - this <- thisNode +renderItemInfo :: Editable -> Category -> Item -> HtmlT IO () +renderItemInfo editable cat item = do + let bg = hueToDarkColor $ getItemHue cat item + div_ [class_ "item-info", style_ ("background-color:" <> bg)] $ do + infoNode <- thisNode case editable of - Editable -> span_ [style_ "font-size:150%"] $ do - -- If the library is on Hackage, the title links to its Hackage page; - -- otherwise, it doesn't link anywhere. Even if the link field is - -- present, it's going to be rendered as “(site)”, not linked in the - -- title. - let hackageLink = "https://hackage.haskell.org/package/" <> item^.name - case item^?kind.onHackage of - Just True -> a_ [href_ hackageLink] (toHtml (item^.name)) - _otherwise -> toHtml (item^.name) - case item^.link of - Just l -> " (" >> a_ [href_ l] "site" >> ")" - Nothing -> return () - emptySpan "1em" + Editable -> do + span_ [style_ "font-size:150%"] $ do + -- If the library is on Hackage, the title links to its Hackage + -- page; otherwise, it doesn't link anywhere. Even if the link + -- field is present, it's going to be rendered as “(site)”, not + -- linked in the title. + let hackageLink = "https://hackage.haskell.org/package/" <> + item^.name + case item^?kind.onHackage of + Just True -> a_ [href_ hackageLink] (toHtml (item^.name)) + _otherwise -> toHtml (item^.name) + case item^.link of + Just l -> " (" >> a_ [href_ l] "site" >> ")" + Nothing -> return () + emptySpan "2em" + toHtml (fromMaybe "other" (item^.group_)) + emptySpan "2em" textButton "edit details" $ - JS.setItemInfoMode (this, item^.uid, InEdit) + JS.setItemInfoMode (infoNode, item^.uid, InEdit) -- TODO: link to Stackage too -- TODO: should check for Stackage automatically InEdit -> do - let handler s = JS.submitItemInfo (this, item^.uid, s) - form_ [onFormSubmit handler] $ do + let traitsNode = format ":has(> {}) > .item-traits" [infoNode] + let formSubmitHandler formNode = + JS.submitItemInfo (infoNode, traitsNode, item^.uid, formNode) + form_ [onFormSubmit formSubmitHandler] $ do label_ $ do "Package name" br_ [] @@ -606,16 +791,49 @@ renderItemInfo editable item = input_ [type_ "text", name_ "link", value_ (fromMaybe "" (item^.link))] br_ [] + label_ $ do + "Group" + br_ [] + customInputId <- tshow <$> randomUid + let selectHandler = [text| + if (this.value == "$newGroupValue") { + $("#$customInputId").show(); + $("#$customInputId").focus(); } + else $("#$customInputId").hide(); |] + select_ [name_ "group", onchange_ selectHandler] $ do + let gs = Nothing : map Just (M.keys (cat^.groups)) + for_ gs $ \group' -> do + -- Text that will be shown in the list (“-” stands for “no + -- group”) + let txt = fromMaybe "-" group' + -- If the element corresponds to the current group of the + -- item (or the element is “-”, i.e. Nothing, and the group + -- is Nothing too), mark it as selected, thus making it the + -- element that will be chosen by default when the form is + -- rendered + if group' == item^.group_ + then option_ [selected_ "selected", value_ txt] (toHtml txt) + else option_ [value_ txt] (toHtml txt) + option_ [value_ newGroupValue] "New group..." + input_ [id_ customInputId, type_ "text", name_ "custom-group", + hidden_ "hidden"] + br_ [] input_ [type_ "submit", value_ "Save"] button "Cancel" [] $ - JS.setItemInfoMode (this, item^.uid, Editable) + JS.setItemInfoMode (infoNode, item^.uid, Editable) -- TODO: categories that don't directly compare libraries but just list all -- libraries about something (e.g. Yesod plugins, or whatever) -renderItemTraits :: Editable -> Item -> HtmlT IO () -renderItemTraits editable item = - div_ [class_ "item-traits"] $ do +-- TODO: categories without items (e.g. “web dev”) that list links to other +-- categories + +renderItemTraits :: Editable -> Category -> Item -> HtmlT IO () +renderItemTraits editable cat item = do + let bg = hueToLightColor $ getItemHue cat item + -- If the structure of HTML changes here, don't forget to update the + -- 'traitsNode' selector in 'renderItemInfo'. + div_ [class_ "item-traits", style_ ("background-color:" <> bg)] $ do this <- thisNode div_ [class_ "traits-groups-container"] $ do div_ [class_ "traits-group"] $ do @@ -719,6 +937,7 @@ imgButton :: Url -> [Attribute] -> JS -> HtmlT IO () imgButton src attrs (JS handler) = a_ [href_ "javascript:void(0)", onclick_ handler] (img_ (src_ src : attrs)) +-- TODO: make this a newtype type JQuerySelector = Text thisNode :: HtmlT IO JQuerySelector @@ -756,3 +975,6 @@ instance ToJS Visible where toJS = JS . tshow . toPathPiece -- TODO: why not compare Haskellers too? + +newGroupValue :: Text +newGroupValue = "-new-group-" diff --git a/static/css.css b/static/css.css index 65d8692..fc78d87 100644 --- a/static/css.css +++ b/static/css.css @@ -18,12 +18,10 @@ body { margin-top: 20px; } .item-info { - padding: 10px 15px; - background-color: #e0e0e0; } + padding: 10px 15px; } .item-traits { - padding: 10px 15px 20px 15px; - background-color: #f0f0f0; } + padding: 10px 15px 20px 15px; } .traits-groups-container { display: flex; }