{-# LANGUAGE QuasiQuotes, OverloadedStrings, FlexibleContexts, ViewPatterns, NoImplicitPrelude #-} module View ( -- * Pages renderRoot, renderDonate, -- * Tracking renderTracking, -- * Methods renderHelp, -- ** Categories renderCategoryList, renderCategory, renderCategoryTitle, renderCategoryNotes, -- ** Items renderItem, renderItemInfo, renderItemDescription, renderItemTraits, renderItemNotes, -- ** Traits renderTrait, -- * Miscellaneous getItemHue, newGroupValue, ) where -- General import BasePrelude hiding (Category) -- Lenses import Lens.Micro.Platform hiding ((&)) -- Monads and monad transformers import Control.Monad.IO.Class -- Containers import qualified Data.Map as M -- Text import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Text (Text) import NeatInterpolation -- Web import Lucid hiding (for_) import Lucid.Base (makeAttribute) -- Local import Types import Utils import JS (JS(..), JQuerySelector) import qualified JS import Markdown {- Note [autosize] ~~~~~~~~~~~~~~~~~~ All textareas on the site are autosized – i.e. they grow when the user is typing. This is done by the autosize.js plugin, which is called on page load: autosize($('textarea')); A slight problem is that it doesn't compute the height of hidden elements correctly – thus, when something is shown and it happens to be a textarea or contain a textarea, we have to call autosize again. This is done in 'JS.switchSection'. So far there are no textboxes that are shown *without* switchSection being involved, and so there's no need to watch for elements being added to the DOM. It would be nicer if we could watch for elements becoming visible without having to modify switchSection, but there doesn't seem to be an easy way to do this – MutationObserver doesn't let us find out when something becomes visible (i.e. when its clientHeight stops being 0). In switchSection we use autosize($('textarea')); autosize.update($('textarea')); instead of simple autosize.update($('textarea')); – this is done because the textarea could have appeared after the original `autosize($('textarea'));` was called on page load (which could happen if an item was added, for instance). -} renderRoot :: GlobalState -> Maybe Text -> HtmlT IO () renderRoot globalState mbSearchQuery = doctypehtml_ $ do head_ $ do title_ "Aelve Guide" let cdnjs = "https://cdnjs.cloudflare.com/ajax/libs/" includeJS (cdnjs <> "jquery/2.2.0/jquery.min.js") -- See Note [autosize] includeJS (cdnjs <> "autosize.js/3.0.15/autosize.min.js") onPageLoad (JS "autosize($('textarea'));") -- It's important that css.css comes second – it overwrites some rules -- from highlight.css (see the rule for div.sourceCode) includeCSS "/highlight.css" includeCSS "/css.css" -- Include definitions of all Javascript functions that we have defined -- in this file. (This isn't an actual file, so don't look for it in the -- static folder – it's generated and served in 'otherMethods'.) includeJS "/js.js" renderTracking -- CSS that makes 'shown' and 'noScriptShown' work noscript_ $ style_ [text| .section:not(.noscript-shown) {display:none;} |] script_ [text| var sheet = document.createElement('style'); sheet.innerHTML = '.section:not(.shown) {display:none;}'; // “head” instead of “body” because body isn't loaded yet document.head.appendChild(sheet); |] body_ $ do -- TODO: [very-easy] this header looks bad when the page is narrow, it -- should be fixed in css.css by adding line-height to it h1_ "A guide to Haskell libraries and tools" noscript_ $ div_ [id_ "noscript-message"] $ toHtml $ renderMarkdownBlock [text| You have Javascript disabled! This site works fine without Javascript, but since all editing needs Javascript to work, you won't be able to edit anything. |] renderHelp onPageLoad $ JS.showOrHideHelp (JS.selectId "help", helpVersion) form_ $ do input_ [type_ "text", name_ "q", id_ "search", placeholder_ "search", value_ (fromMaybe "" mbSearchQuery)] textInput [ placeholder_ "add a category", autocomplete_ "off", onEnter $ JS.addCategory (JS.selectId "categories", inputValue) <> clearInput ] -- TODO: sort categories by popularity, somehow? or provide a list of -- “commonly used categories” or even a nested catalog case mbSearchQuery of Nothing -> renderCategoryList (globalState^.categories) Just query' -> do let queryWords = T.words query' let rank :: Category -> Int rank cat = sum [ length (queryWords `intersect` (cat^..items.each.name)), length (queryWords `intersect` T.words (cat^.title)) ] let rankedCategories | null queryWords = globalState^.categories | otherwise = filter ((/= 0) . rank) . reverse . sortOn rank $ globalState^.categories renderCategoryList rankedCategories -- TODO: perhaps use infinite scrolling/loading? -- TODO: maybe add a button like “give me random category that is -- unfinished” div_ [id_ "footer"] $ do "made by " >> a_ [href_ "https://artyom.me"] "Artyom" emptySpan "2em" a_ [href_ "https://github.com/aelve/guide"] "source" emptySpan "2em" a_ [href_ "https://github.com/aelve/guide/issues"] "report an issue" emptySpan "2em" a_ [href_ "/donate"] "donate" sup_ [style_ "font-size:50%"] "I don't have a job" -- TODO: when submitting a text field, gray it out (but leave it selectable) -- until it's been submitted renderTracking :: HtmlT IO () renderTracking = do trackingEnabled <- (== Just "1") <$> liftIO (lookupEnv "GUIDE_TRACKING") when trackingEnabled $ do tracking <- liftIO $ T.readFile "static/tracking.html" toHtmlRaw tracking -- TODO: include jQuery locally so that it'd be possible to test the site -- without internet renderDonate :: HtmlT IO () renderDonate = doctypehtml_ $ do head_ $ do title_ "Donate to Artyom" includeCSS "/css.css" renderTracking -- TODO: move this into its own file in static/? body_ $ do toHtml $ renderMarkdownBlock [text| Okay, the rules: if you donate *anything*, I'll spend some time working on the site this day (adding content, implementing new features, etc). (Of course, I'm planning to be working on the site anyway, donations or not! However, I jump from project to project way too often (and rarely manage to finish anything), so donating money is a good way to make sure that I'd feel obligated to keep working on this one. If I find out that it doesn't work as a motivation, I'll stop accepting donations.) Just in case, 1000 rub. is 14$ (or 12.5€), and you can choose any amount below 15000 rub. (I'd put a Paypal button, but Paypal doesn't allow receiving money in Belarus.) |] style_ [text| #iframe-hold { background: url(loading.svg) center center no-repeat; } |] div_ [id_ "iframe-hold"] $ iframe_ [ makeAttribute "frameborder" "0", makeAttribute "allowtransparency" "true", makeAttribute "scrolling" "no", width_ "450", height_ "197", style_ "display:block;margin:auto;", src_ "https://money.yandex.ru/embed/shop.xml\ \?account=410011616040682\ \&quickpay=shop\ \&payment-type-choice=on\ \&mobile-payment-type-choice=on\ \&writer=seller\ \&targets=Haskell+guide\ \&targets-hint=\ \&default-sum=1000\ \&button-text=04\ \&successURL=" ] "" -- TODO: allow archiving items if they are in every way worse than the rest, -- or something (but searching should still be possible) -- TODO: add a list for “interesting libraries, but too lazy to describe, so -- somebody describe them for me” renderHelp :: HtmlT IO () renderHelp = do div_ [id_ "help"] $ do -- If you're going to change section names, look at 'JS.showHelp' and -- 'JS.hideHelp' section "collapsed" [shown] $ do textButton "show help" $ JS.showHelp (JS.selectId "help", helpVersion) section "expanded" [noScriptShown] $ do textButton "hide help" $ JS.hideHelp (JS.selectId "help", helpVersion) -- Don't forget to change 'helpVersion' when the text changes -- substantially and you think the users should reread it help <- liftIO $ T.readFile "static/help.md" toHtml $ renderMarkdownBlock help helpVersion :: Int helpVersion = 2 -- TODO: when conflicts happen, maybe create an alert like “The thing you're -- editing has been edited in the meantime. Here is a link with a diff of -- your variant and the other person's variant. Please merge the changes -- manually and submit them again, or press this button and we'll merge the -- changes for you (don't worry, it's not a big deal for us). Thanks!” -- TODO: automatic merge should be possible too (e.g. if the changes are in -- different paragraphs) renderCategoryList :: [Category] -> HtmlT IO () renderCategoryList cats = div_ [id_ "categories"] $ mapM_ renderCategory cats renderCategoryTitle :: Category -> HtmlT IO () renderCategoryTitle category = do let thisId = "category-title-" <> uidToText (category^.uid) this = JS.selectId thisId -- TODO: once pagination or something is implemented, we'll have to see -- whether an anchor has been used in the query string and load the -- necessary category if so h2_ [id_ thisId] $ do a_ [class_ "anchor", href_ ("/#" <> uidToText (category^.uid))] "#" sectionSpan "normal" [shown, noScriptShown] $ do toHtml (category^.title) emptySpan "1em" textButton "edit" $ JS.switchSection (this, "editing" :: Text) sectionSpan "editing" [] $ do textInput [ value_ (category^.title), autocomplete_ "off", onEnter $ JS.submitCategoryTitle (this, category^.uid, inputValue)] emptySpan "1em" textButton "cancel" $ JS.switchSection (this, "normal" :: Text) renderCategoryNotes :: Category -> HtmlT IO () renderCategoryNotes category = do let thisId = "category-notes-" <> uidToText (category^.uid) this = JS.selectId thisId div_ [id_ thisId] $ do section "normal" [shown, noScriptShown] $ do if category^.notes == "" then p_ "write something here!" else toHtml (category^.notes) textButton "edit description" $ JS.switchSection (this, "editing" :: Text) section "editing" [] $ markdownEditor (category^.notes) (\val -> JS.submitCategoryNotes (this, category^.uid, val)) (JS.switchSection (this, "normal" :: Text)) renderCategory :: Category -> HtmlT IO () renderCategory category = div_ [class_ "category", uid_ (category^.uid)] $ do renderCategoryTitle category renderCategoryNotes category itemsNode <- div_ [class_ "items"] $ do mapM_ (renderItem category) (category^.items) thisNode textInput [ placeholder_ "add an item", autocomplete_ "off", onEnter $ JS.addItem (itemsNode, category^.uid, inputValue) <> clearInput ] 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 :: Category -> Item -> HtmlT IO () renderItem cat item = div_ [id_ ("item-" <> uidToText (item^.uid)), class_ "item"] $ do renderItemInfo cat item -- TODO: replace “edit description” with a big half-transparent pencil -- to the left of it renderItemDescription cat item renderItemTraits cat item -- TODO: [very-easy] add a separator here? renderItemNotes cat item -- TODO: some spinning thingy that spins in the corner of the page while a -- request is happening -- 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 :: Category -> Item -> HtmlT IO () renderItemInfo cat item = do let bg = hueToDarkColor $ getItemHue cat item let thisId = "item-info-" <> uidToText (item^.uid) this = JS.selectId thisId div_ [id_ thisId, class_ "item-info", style_ ("background-color:" <> bg)] $ do section "normal" [shown, noScriptShown] $ do -- TODO: [very-easy] move this style_ into css.css span_ [style_ "font-size:150%"] $ do let hackageLink x = "https://hackage.haskell.org/package/" <> x case item^.kind of -- 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. Library hackageName' -> do case hackageName' of Just x -> a_ [href_ (hackageLink x)] (toHtml (item^.name)) Nothing -> toHtml (item^.name) case item^.link of Just l -> " (" >> a_ [href_ l] "site" >> ")" Nothing -> return () -- For tools, it's the opposite – the title links to the item site -- (if present), and there's a separate “(Hackage)” link if the -- tool is on Hackage. Tool hackageName' -> do case item^.link of Just l -> a_ [href_ l] (toHtml (item^.name)) Nothing -> toHtml (item^.name) case hackageName' of Just x -> " (" >> a_ [href_ (hackageLink x)] "Hackage" >> ")" Nothing -> return () -- And now everything else Other -> do case item^.link of Just l -> a_ [href_ l] (toHtml (item^.name)) Nothing -> toHtml (item^.name) emptySpan "2em" toHtml (fromMaybe "other" (item^.group_)) span_ [class_ "controls"] $ do let itemNode = JS.selectId ("item-" <> uidToText (item^.uid)) imgButton "move item up" "/arrow-thick-top.svg" [] $ -- TODO: [easy] the item should blink or somehow else show where it -- has been moved JS.moveItemUp (item^.uid, itemNode) imgButton "move item down" "/arrow-thick-bottom.svg" [] $ JS.moveItemDown (item^.uid, itemNode) emptySpan "1.5em" imgButton "edit item info" "/pencil.svg" [] $ JS.switchSection (this, "editing" :: Text) emptySpan "0.5em" imgButton "delete item" "/x.svg" [] $ JS.deleteItem (item^.uid, itemNode) -- TODO: link to Stackage too -- TODO: should check for Stackage automatically section "editing" [] $ do let selectedIf p x = if p then with x [selected_ "selected"] else x -- otherNodes are all nodes that have to be recolored when this node is -- recolored let otherNodes = JS.selectChildren (JS.selectParent this) (JS.selectClass "item-body") let formSubmitHandler formNode = JS.submitItemInfo (this, otherNodes, item^.uid, formNode) form_ [onFormSubmit formSubmitHandler] $ do -- All inputs have "autocomplete = off" thanks to -- label_ $ do "Name" >> br_ [] input_ [type_ "text", name_ "name", autocomplete_ "off", value_ (item^.name)] br_ [] label_ $ do "Kind" >> br_ [] select_ [name_ "kind"] $ do option_ [value_ "library"] "Library" & selectedIf (case item^.kind of Library{} -> True; _ -> False) option_ [value_ "tool"] "Tool" & selectedIf (case item^.kind of Tool{} -> True; _ -> False) option_ [value_ "other"] "Other" & selectedIf (case item^.kind of Other{} -> True; _ -> False) br_ [] label_ $ do "Name on Hackage" >> br_ [] input_ [type_ "text", name_ "hackage-name", autocomplete_ "off", value_ (fromMaybe "" (item^?kind.hackageName._Just))] br_ [] label_ $ do "Site (optional)" >> br_ [] input_ [type_ "text", name_ "link", autocomplete_ "off", value_ (fromMaybe "" (item^.link))] br_ [] newGroupInputId <- randomUid label_ $ do "Group" >> br_ [] -- When “new group” is selected in the list, we show a field for -- entering new group's name -- -- TODO: when a new group is created, add it to all other lists in -- forms in the category let selectHandler = [text| if (this.value == "$newGroupValue") { $("#$idText").show(); $("#$idText").focus(); } else $("#$idText").hide(); |] where idText = uidToText newGroupInputId select_ [name_ "group", autocomplete_ "off", 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 option_ [value_ txt] (toHtml txt) & selectedIf (group' == item^.group_) option_ [value_ newGroupValue] "New group..." input_ [uid_ newGroupInputId, type_ "text", autocomplete_ "off", name_ "custom-group", hidden_ "hidden"] br_ [] input_ [type_ "submit", value_ "Save"] button "Cancel" [] $ JS.switchSection (this, "normal" :: Text) -- TODO: use triangle icons instead of arrows [very-easy] -- TODO: categories that don't directly compare libraries but just list all -- libraries about something (e.g. Yesod plugins, or whatever) -- TODO: categories without items (e.g. “web dev”) that list links to other -- categories renderItemDescription :: Category -> Item -> HtmlT IO () renderItemDescription category item = do let bg = hueToLightColor $ getItemHue category item -- If the structure of HTML changes here, don't forget to update the -- 'otherNodes' selector in 'renderItemInfo'. Specifically, we depend on -- having a div with a class “item-body” here. let thisId = "item-description-" <> uidToText (item^.uid) this = JS.selectId thisId div_ [id_ thisId, class_ "item-description item-body", style_ ("background-color:" <> bg)] $ do section "normal" [shown, noScriptShown] $ do if item^.description == "" then p_ "write something here!" else toHtml (item^.description) textButton "edit description" $ JS.switchSection (this, "editing" :: Text) section "editing" [] $ markdownEditor (item^.description) (\val -> JS.submitItemDescription (this, item^.uid, val)) (JS.switchSection (this, "normal" :: Text)) renderItemTraits :: Category -> Item -> HtmlT IO () renderItemTraits cat item = do let bg = hueToLightColor $ getItemHue cat item -- If the structure of HTML changes here, don't forget to update the -- 'otherNodes' selector in 'renderItemInfo'. Specifically, we depend on -- having a div with a class “item-body” here. div_ [class_ "item-traits item-body", style_ ("background-color:" <> bg)] $ do this <- thisNode div_ [class_ "traits-groups-container"] $ do div_ [class_ "traits-group"] $ do p_ "Pros:" -- We can't use 'thisNode' inside