guide/lib/View.hs

{-# LANGUAGE
QuasiQuotes,
OverloadedStrings,
FlexibleContexts,
NoImplicitPrelude
  #-}


module View
(
  getJS,
  getCSS,

  -- * Pages
  renderRoot,
  renderAdmin,
  renderEdits,
  renderHaskellRoot,
  renderDonate,
  renderCategoryPage,
  renderStaticMd,
  renderSearchResults,

  -- * Methods
  -- ** Categories
  renderCategoryList,
  renderCategory,
  renderCategoryInfo,
  renderCategoryNotes,
  -- ** Items
  renderItem,
  renderItemInfo,
  renderItemDescription,
  renderItemEcosystem,
  renderItemTraits,
  renderItemNotes,
  -- ** Traits
  renderTrait,

  -- * Rendering for feeds
  renderItemForFeed,

  -- * Miscellaneous
  getItemHue,
)
where


import BasePrelude hiding (Category)
-- Lenses
import Lens.Micro.Platform hiding ((&))
-- Monads and monad transformers
import Control.Monad.IO.Class
import Control.Monad.Catch
import Control.Monad.Reader
-- Lists
import Data.List.Split
-- Containers
import qualified Data.Map as M
import Data.Tree
-- Text
import qualified Data.Text.All as T
import qualified Data.Text.Lazy.All as TL
import Data.Text.All (Text)
import NeatInterpolation
-- Web
import Lucid hiding (for_)
-- Files
import System.FilePath
import qualified System.FilePath.Find as F
-- Network
import Data.IP
-- Time
import Data.Time
import Data.Time.Format.Human
-- Markdown
import qualified CMark as MD
-- Mustache (templates)
import Text.Mustache.Plus
import qualified Data.Aeson as A
import qualified Data.Aeson.Encode.Pretty as A
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Semigroup as Semigroup
import qualified Data.List.NonEmpty as NonEmpty
import Text.Megaparsec
import Text.Megaparsec.Text

-- Local
import Config
import Types
import Utils
import JS (JS(..), JQuerySelector)
import qualified JS
import Markdown
import Cache


{- 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).

-}

{- Note [show-hide]
~~~~~~~~~~~~~~~~~~~

A lot of things (notes, etc) can be expanded/collapsed by pressing a button. Similarly, pressing “edit” replaces rendered text with a textbox, or adds buttons to pros/cons. All this is done with sections and show/hide.

A section is something that can be shown or hidden. You define a section by using 'section' (which creates a <div>) or 'sectionSpan' (which creates a <span>).

    section "normal" [shown, noScriptShown] $ do
      renderText
      ...

    section "editing" [] $ do
      renderEditbox
      ...

You can even give 2 names to a section – e.g. "normal editing" if you want the section be visible both in “normal” mode and in “editing” mode.

The list parameter is used to add attributes to the section. 'shown' is an attribute that means that the section is normally visible; 'noScriptShown' means that the section will be visible when Javascipt is disabled. Sections without either attribute will be hidden. (Usually 'shown' and 'noScriptShown' go together, but not always.)

When several sections are in the same container (e.g. a <div>), you can toggle between them with 'JS.switchSection', which shows the section (or several sections) with given name, and hides all sections with other names. The elements that aren't sections are not affected.

Also, there's another function available – 'JS.switchSectionEverywhere' – that switches sections everywhere inside the container, not only among container's direct children. It's useful when you have something like a list of pros/cons and you want to switch them all into the “editable” state.

////////////////////////////////////

And now, here's how it's all implemented.

In 'wrapPage' there's a piece of CSS wrapped in <noscript> that hides everything except for 'noScriptShown' things:

    .section:not(.noscript-shown) {display:none;}

There's also a piece of Javascript that, when executed, will change it to the following CSS:

    .section:not(.shown) {display:none;}

So, if Javascript is disabled we hide all sections except for those that have the 'noScriptShown' attribute, and if it's enabled we hide all sections except for those that have the 'shown' attribute.

After that switching sections is simply done by adding/removing the “shown” class. (Note that we don't have to choose between “noscript-shown” and “shown” because switching sections is *only* possible if Javascript is enabled, and in this case the relevant tag will always be “shown” and not “noscript-shown”.)

-}

renderSubtitle :: Monad m => HtmlT m ()
renderSubtitle =
  div_ [class_ "subtitle"] $
    "alpha version • very much incomplete • leave feedback"

renderRoot :: (MonadIO m, MonadReader Config m) => HtmlT m ()
renderRoot = do
  wrapPage "Aelve Guide" $ do
    h1_ "Aelve Guide"
    renderSubtitle
    h2_ (mkLink "Haskell" "/haskell")

-- TODO: show a “category not found” page

renderAdmin :: (MonadIO m) => GlobalState -> HtmlT m ()
renderAdmin globalState = do
  head_ $ do
    includeJS "/js.js"
    includeJS "/jquery.js"
    includeJS "/sorttable.js"
    includeCSS "/markup.css"
    includeCSS "/admin.css"
    includeCSS "/loader.css"
    title_ "admin – Aelve Guide"
    meta_ [name_ "viewport",
           content_ "width=device-width, initial-scale=1.0, user-scalable=yes"]

  body_ $ do
    script_ $ fromJS $ JS.createAjaxIndicator ()
    h1_ "Miscellaneous"
    buttonUid <- randomLongUid
    button "Create checkpoint" [uid_ buttonUid] $
      JS.createCheckpoint [JS.selectUid buttonUid]
    div_ [id_ "stats"] $
      renderStats globalState (globalState ^. actions)
    div_ [id_ "edits"] $
      renderEdits globalState (map (,Nothing) (globalState ^. pendingEdits))

renderStats
  :: (MonadIO m)
  => GlobalState
  -> [(Action, ActionDetails)]
  -> HtmlT m ()
renderStats globalState acts = do
  h1_ "Statistics"
  p_ "All information is for last 31 days."
  now <- liftIO getCurrentTime
  let thisMonth (_, d) = diffUTCTime now (actionDate d) <= 31*86400
      acts' = takeWhile thisMonth acts
  p_ $ do
    "Main page visits: "
    strong_ $ toHtml $ show $ length [() | (Action'MainPageVisit, _) <- acts']
    ". "
    "Edits: "
    strong_ $ toHtml $ show $ length [() | (Action'Edit _, _) <- acts']
    ". "
    "Unique visitors: "
    strong_ $ toHtml $ show $ length $ ordNub $ map (actionIP.snd) acts'
    "."
  let allCategories = globalState^.categories ++
                      globalState^.categoriesDeleted
  -- TODO: move this somewhere else (it's also used in renderEdit)
  let findCategory catId = fromMaybe err (find (hasUid catId) allCategories)
        where
          err = error ("renderStats: couldn't find category with uid = " ++
                       T.unpack (uidToText catId))
  table_ [class_ "sortable"] $ do
    thead_ $ tr_ $ do
      th_ [class_ "sorttable_nosort"] "Category"
      th_ "Visits"
      th_ "Unique visitors"
    tbody_ $ do
      let rawVisits :: [(Uid Category, Maybe IP)]
          rawVisits = [(catId, actionIP d) |
                       (Action'CategoryVisit catId, d) <- acts']
      let visits :: [(Uid Category, (Int, Int))]
          visits = map (over _2 (length &&& length.ordNub)) .
                   map (fst.head &&& map snd) .
                   groupWith fst
                     $ rawVisits
      for_ (reverse $ sortWith (fst.snd) visits) $ \(catId, (n, u)) -> do
        tr_ $ do
          td_ (toHtml (findCategory catId ^. title))
          td_ (toHtml (show n))
          td_ (toHtml (show u))
  table_ [class_ "sortable"] $ do
    thead_ $ tr_ $ do
      th_ [class_ "sorttable_nosort"] "Search"
      th_ "Repetitions"
    tbody_ $ do
      let searches = map (head &&& length) . group $
            [s | (Action'Search s, _) <- acts']
      for_ (reverse $ sortWith snd searches) $ \(s, n) -> do
        tr_ $ do
          td_ (toHtml s)
          td_ (toHtml (show n))
  table_ [class_ "sortable"] $ do
    thead_ $ tr_ $ do
      th_ [class_ "sorttable_nosort"] "Referrer"
      th_ "Visitors"
      th_ "Unique visitors"
    tbody_ $ do
      let rawVisits :: [(Url, Maybe IP)]
          rawVisits = [(r, actionIP d) |
                       (_, d) <- acts',
                       Just (ExternalReferrer r) <- [actionReferrer d]]
      let visits :: [(Url, (Int, Int))]
          visits = map (over _2 (length &&& length.ordNub)) .
                   map (fst.head &&& map snd) .
                   groupWith fst
                     $ rawVisits
      for_ (reverse $ sortWith (fst.snd) visits) $ \(r, (n, u)) -> do
        tr_ $ do
          td_ (toHtml r)
          td_ (toHtml (show n))
          td_ (toHtml (show u))
  table_ $ do
    thead_ $ tr_ $ do
      th_ "Action"
      th_ "Date"
      th_ "IP"
    tbody_ $ do
      -- acts, not acts' (what if there were less than 10 actions in the last
      -- month?)
      for_ (take 10 acts) $ \(a, d) -> tr_ $ do
        td_ $ case a of
          Action'Edit _          -> "Edit"
          Action'MainPageVisit   -> "Main page visit"
          Action'CategoryVisit _ -> "Category visit"
          Action'Search _        -> "Search"
        td_ $ toHtml =<< liftIO (humanReadableTime (actionDate d))
        td_ $ case actionIP d of
          Nothing -> "<unknown IP>"
          Just ip -> toHtml (show ip)

-- TODO: when showing Edit'DeleteCategory, show the amount of items in that
-- category and titles of items themselves

-- | Group edits by IP and render them
renderEdits
  :: (MonadIO m)
  => GlobalState
  -> [((Edit, EditDetails), Maybe String)]
  -> HtmlT m ()
renderEdits globalState edits = do
  let getIP = editIP . snd . fst
  -- Unlike 'groupWith', “groupBy . equating” doesn't sort the input.
  let editBlocks = groupBy (equating getIP) edits
  let ipNum = length $ groupWith getIP edits
  h1_ $ toHtml $
    T.format "Pending edits (IPs: {}, blocks: {})" (ipNum, length editBlocks)
  for_ editBlocks $ \editBlock -> div_ $ do
    blockNode <- thisNode
    h2_ $ do
      case editIP (editBlock ^?! _head._1._2) of
        Nothing -> "<unknown IP>"
        Just ip -> toHtml (show ip)
      emptySpan "1em"
      textButton "accept all" $
        JS.acceptBlock (editId (editBlock ^?! _head._1._2),
                        editId (editBlock ^?! _last._1._2),
                        blockNode)
      emptySpan "0.5em"
      textButton "undo all" $
        JS.undoBlock (editId (editBlock ^?! _head._1._2),
                      editId (editBlock ^?! _last._1._2),
                      blockNode)
    for_ editBlock $ \((edit, EditDetails{..}), mbErr) ->
      div_ [class_ "edit"] $ do
        editNode <- thisNode
        p_ [class_ "edit-info"] $ do
          toHtml =<< liftIO (humanReadableTime editDate)
          emptySpan "1em"
          textButton "accept" $
            JS.acceptEdit (editId, editNode)
          emptySpan "0.5em"
          textButton "try to undo" $
            JS.undoEdit (editId, editNode)
        case mbErr of
          Nothing  -> return ()
          Just err -> p_ $ span_ [style_ "background-color:#E57373"] $
            "Can't apply the edit: " >> toHtml err
        renderEdit globalState edit

renderEdit :: Monad m => GlobalState -> Edit -> HtmlT m ()
renderEdit globalState edit = do
  let quote :: Monad m => HtmlT m () -> HtmlT m ()
      quote a = "“" *> a <* "”"
  -- We're searching for everything (items/categories) both in normal lists
  -- and in lists of deleted things. Just in case.
  let allCategories = globalState^.categories ++
                      globalState^.categoriesDeleted
  let findCategory catId = fromMaybe err (find (hasUid catId) allCategories)
        where
          err = error ("renderEdit: couldn't find category with uid = " ++
                       T.unpack (uidToText catId))
  let findItem itemId = (category, item)
        where
          getItems = view (items <> itemsDeleted)
          ourCategory = any (hasUid itemId) . getItems
          err = error ("renderEdit: couldn't find item with uid = " ++
                       T.unpack (uidToText itemId))
          category = fromMaybe err (find ourCategory allCategories)
          item = fromJust (find (hasUid itemId) (getItems category))
  let findTrait itemId traitId = (category, item, trait)
        where
          (category, item) = findItem itemId
          getTraits = view (cons <> consDeleted <> pros <> prosDeleted)
          err = error ("renderEdit: couldn't find trait with uid = " ++
                       T.unpack (uidToText traitId))
          trait = fromMaybe err (find (hasUid traitId) (getTraits item))

  let printCategory catId = do
        let category = findCategory catId
        quote $ a_ [href_ (categoryLink category)] $
          toHtml (category ^. title)
  let printItem itemId = do
        let (category, item) = findItem itemId
        quote $ a_ [href_ (itemLink category item)] $
          toHtml (item ^. name)

  case edit of
    -- Add
    Edit'AddCategory _catId title' -> p_ $ do
      "added category " >> quote (toHtml title')
    Edit'AddItem catId _itemId name' -> p_ $ do
      "added item " >> quote (toHtml name')
      " to category " >> printCategory catId
    Edit'AddPro itemId _traitId content' -> do
      p_ $ "added pro to item " >> printItem itemId
      blockquote_ $ p_ $ toHtml (toMarkdownInline content')
    Edit'AddCon itemId _traitId content' -> do
      p_ $ "added con to item " >> printItem itemId
      blockquote_ $ p_ $ toHtml (toMarkdownInline content')

    -- Change category properties
    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'SetCategoryStatus catId oldStatus newStatus -> p_ $ do
      "changed status of category " >> printCategory catId
      " from " >> quote (toHtml (show oldStatus))
      " to "   >> quote (toHtml (show newStatus))
    Edit'SetCategoryNotes catId oldNotes newNotes -> do
      p_ $ "changed notes of category " >> printCategory catId
      table_ $ tr_ $ do
        td_ $ blockquote_ $ toHtml (toMarkdownBlock oldNotes)
        td_ $ blockquote_ $ toHtml (toMarkdownBlock newNotes)
    Edit'SetCategoryProsConsEnabled catId _oldVal newVal -> do
      if newVal == True
        then p_ $ "enabled pros/cons for category " >> printCategory catId
        else p_ $ "disabled pros/cons for category " >> printCategory catId
    Edit'SetCategoryEcosystemEnabled catId _oldVal newVal -> do
      if newVal == True
        then p_ $ "enabled ecosystem for category " >> printCategory catId
        else p_ $ "disabled ecosystem for category " >> printCategory catId

    -- Change item properties
    Edit'SetItemName _itemId oldName newName -> p_ $ do
      "changed name of item " >> quote (toHtml oldName)
      " to " >> quote (toHtml newName)
    Edit'SetItemLink itemId oldLink newLink -> p_ $ do
      "changed link of item " >> printItem itemId
      " from " >> code_ (toHtml (show oldLink))
      " to "   >> code_ (toHtml (show newLink))
    Edit'SetItemGroup itemId oldGroup newGroup -> p_ $ do
      "changed group of item " >> printItem itemId
      " from " >> code_ (toHtml (show oldGroup))
      " to "   >> code_ (toHtml (show newGroup))
    Edit'SetItemKind itemId oldKind newKind -> p_ $ do
      "changed kind of item " >> printItem itemId
      " from " >> code_ (toHtml (show oldKind))
      " to "   >> code_ (toHtml (show newKind))
    Edit'SetItemDescription itemId oldDescr newDescr -> do
      p_ $ "changed description of item " >> printItem itemId
      table_ $ tr_ $ do
        td_ $ blockquote_ $ toHtml (toMarkdownBlock oldDescr)
        td_ $ blockquote_ $ toHtml (toMarkdownBlock newDescr)
    Edit'SetItemNotes itemId oldNotes newNotes -> do
      p_ $ "changed notes of item " >> printItem itemId
      table_ $ tr_ $ do
        td_ $ blockquote_ $ toHtml (toMarkdownBlock oldNotes)
        td_ $ blockquote_ $ toHtml (toMarkdownBlock newNotes)
    Edit'SetItemEcosystem itemId oldEcosystem newEcosystem -> do
      p_ $ "changed ecosystem of item " >> printItem itemId
      table_ $ tr_ $ do
        td_ $ blockquote_ $ toHtml (toMarkdownBlock oldEcosystem)
        td_ $ blockquote_ $ toHtml (toMarkdownBlock newEcosystem)

    -- Change trait properties
    Edit'SetTraitContent itemId _traitId oldContent newContent -> do
      p_ $ "changed trait of item " >> printItem itemId
      table_ $ tr_ $ do
        td_ $ blockquote_ $ p_ (toHtml (toMarkdownInline oldContent))
        td_ $ blockquote_ $ p_ (toHtml (toMarkdownInline newContent))

    -- Delete
    Edit'DeleteCategory catId _pos -> p_ $ do
      "deleted category " >> printCategory catId
    Edit'DeleteItem itemId _pos -> p_ $ do
      let (category, item) = findItem itemId
      "deleted item " >> quote (toHtml (item^.name))
      " from category " >> quote (toHtml (category^.title))
    Edit'DeleteTrait itemId traitId _pos -> do
      let (_, item, trait) = findTrait itemId traitId
      p_ $ "deleted trait from item " >> quote (toHtml (item^.name))
      blockquote_ $ p_ $ toHtml (trait^.content)

    -- Other
    Edit'MoveItem itemId direction -> p_ $ do
      "moved item " >> printItem itemId
      if direction then " up" else " down"
    Edit'MoveTrait itemId traitId direction -> do
      let (_, item, trait) = findTrait itemId traitId
      p_ $ "moved trait of item " >> quote (toHtml (item^.name)) >>
           if direction then " up" else " down"
      blockquote_ $ p_ $ toHtml (trait^.content)

-- TODO: use “data Direction = Up | Down” for directions instead of Bool

renderHaskellRoot
  :: (MonadIO m, MonadThrow m, MonadReader Config m)
  => GlobalState -> Maybe Text -> HtmlT m ()
renderHaskellRoot globalState mbSearchQuery =
  wrapPage "Aelve Guide: Haskell" $ do
    onPageLoad $ JS.expandHash ()
    case mbSearchQuery of
      Nothing -> h1_ "Aelve Guide: Haskell"
      -- A search page isn't the main page, so we need a link to the main page
      Just _  -> h1_ (mkLink "Aelve Guide: Haskell" "/haskell")
    renderSubtitle
    renderNoScriptWarning
    renderSearch mbSearchQuery
    textInput [
      placeholder_ "add a category",
      class_ "add-category",
      autocomplete_ "off",
      onEnter $ JS.addCategoryAndRedirect [inputValue] ]
    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
        renderSearchResults rankedCategories
    -- TODO: maybe add a button like “give me random category that is
    -- unfinished”

renderCategoryPage
  :: (MonadIO m, MonadThrow m, MonadReader Config m)
  => Category -> HtmlT m ()
renderCategoryPage category = do
  wrapPage (category^.title <> " – Haskell – Aelve Guide") $ do
    onPageLoad $ JS.expandHash ()
    -- TODO: another absolute link [absolute-links]
    h1_ (mkLink "Aelve Guide: Haskell" "/haskell")
    renderSubtitle
    renderNoScriptWarning
    renderSearch Nothing
    renderCategory category

renderNoScriptWarning :: Monad m => HtmlT m ()
renderNoScriptWarning =
  noscript_ $ div_ [id_ "noscript-message"] $
    toHtml $ toMarkdownBlock [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.
      |]

renderDonate
  :: (MonadIO m, MonadReader Config m) => HtmlT m ()
renderDonate = wrapPage "Donate to Artyom" $ do
  toHtmlRaw =<< liftIO (readFile "static/donate.html")

renderStaticMd
  :: (MonadIO m, MonadReader Config m)
  => Text -> String -> HtmlT m ()
renderStaticMd t fn = wrapPage t $
  toHtml . toMarkdownBlock =<< liftIO (T.readFile ("static/" ++ fn))

-- Include all the necessary things
wrapPage
  :: (MonadIO m, MonadReader Config m)
  => Text                              -- ^ Page title
  -> HtmlT m ()
  -> HtmlT m ()
wrapPage pageTitle page = doctypehtml_ $ do
  head_ $ do
    title_ (toHtml pageTitle)
    meta_ [name_ "viewport",
           content_ "width=device-width, initial-scale=1.0, user-scalable=yes"]
    link_ [rel_ "icon", href_ "/favicon.ico"]
    googleToken <- _googleToken <$> lift ask
    unless (T.null googleToken) $
      meta_ [name_ "google-site-verification", content_ googleToken]
    -- Report all Javascript errors with alerts
    script_ [text|
      window.onerror = function (msg, url, lineNo, columnNo, error) {
        alert("Error in "+url+" at "+lineNo+":"+columnNo+": "+msg+
              "\n\n"+
              "========== Please report it! =========="+
              "\n\n"+
              "https://github.com/aelve/guide/issues");
        return false; };
      |]
    includeJS "/jquery.js"
    -- for modal dialogs
    includeJS "/magnific-popup.js"
    includeCSS "/magnific-popup.css"
    -- See Note [autosize]
    includeJS "/autosize.js"
    onPageLoad (JS "autosize($('textarea'));")
    -- The order is important – markup.css overrides some rules from
    -- highlight.css (e.g. div.sourceCode), css.css overrides the rule for
    -- a.anchor from markup.css.
    --
    -- TODO: maybe use !important or something instead?
    includeCSS "/highlight.css"
    includeCSS "/markup.css"
    includeCSS "/css.css"
    includeCSS "/loader.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"
    -- CSS that makes 'shown' and 'noScriptShown' work;
    -- see Note [show-hide]
    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
    script_ $ fromJS $ JS.createAjaxIndicator ()
    div_ [id_ "main"] $
      page
    div_ [id_ "footer"] $ do
      mapM_ (div_ [class_ "footer-item"]) $
        [ do "made by "
             mkLink "Artyom" "https://artyom.me"
        , do mkLink "source" "https://github.com/aelve/guide"
             "/"
             mkLink "issue tracker" "https://github.com/aelve/guide/issues"
        , mkLink "rules" "/unwritten-rules"
        , do div_ (mkLink "donate" "/donate")
             div_ [class_ "unemployed"] "I don't have a job"
        , do "licensed under "
             mkLink "CC+ BY-SA 4.0" "/license"
        ]

renderSearch :: (MonadIO m, MonadThrow m) => Maybe Text -> HtmlT m ()
renderSearch mbSearchQuery =
  mustache "search" $ A.object [
    "query" A..= mbSearchQuery ]

-- If the presentation of the category list ever changes (e.g. to include
-- lists of items in categories, or their counts, or something), you might
-- have to start invalidating 'CacheCategoryList' in more things in
-- 'Cache.invalidateCache'.
renderCategoryList :: MonadIO 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]
          let cl = case category^.status of
                CategoryFinished   -> "status-finished"
                CategoryMostlyDone -> "status-mostly-done"
                CategoryWIP        -> "status-wip"
                CategoryStub       -> "status-stub"
          a_ [class_ cl, href_ (categoryLink category)] $
            toHtml (category^.title)
          case category^.status of
            CategoryFinished   -> return ()
            CategoryMostlyDone -> span_ [class_ "status"] "mostly done"
            CategoryWIP        -> span_ [class_ "status"] "work in progress"
            CategoryStub       -> span_ [class_ "status"] "stub"
          br_ []

renderSearchResults :: Monad m => [Category] -> HtmlT m ()
renderSearchResults cats = do
  div_ [id_ "categories"] $
    for_ cats $ \category -> do
      a_ [href_ (categoryLink category)] $
        toHtml (category^.title)
      br_ []

renderCategoryInfo :: MonadIO m => Category -> HtmlT m ()
renderCategoryInfo category = cached (CacheCategoryInfo (category^.uid)) $ do
  let thisId = "category-info-" <> uidToText (category^.uid)
      this   = JS.selectId thisId
  div_ [id_ thisId, class_ "category-info"] $ do

    section "normal" [shown, noScriptShown] $ h2_ $ do
      -- TODO: this link shouldn't be absolute [absolute-links]
      span_ [class_ "controls"] $
        a_ [href_ ("/haskell/feed/category/" <> uidToText (category^.uid))] $
          img_ [src_ "/rss-alt.svg",
                alt_ "category feed", title_ "category feed"]
      a_ [href_ (categoryLink category)] $
        toHtml (category^.title)
      emptySpan "1em"
      span_ [class_ "group"] $
        toHtml (category^.group_)
      emptySpan "1em"
      textButton "edit" $
        JS.switchSection (this, "editing" :: Text)
      emptySpan "1em"
      textButton "delete" $
        JS.deleteCategoryAndRedirect [category^.uid]

    section "editing" [] $ do
      let formSubmitHandler formNode =
            JS.submitCategoryInfo (this, category^.uid, formNode)
      form_ [onFormSubmit formSubmitHandler] $ do
        -- All inputs have "autocomplete = off" thanks to
        -- <http://stackoverflow.com/q/8311455>
        label_ $ do
          "Title" >> br_ []
          input_ [type_ "text", name_ "title",
                  autocomplete_ "off",
                  value_ (category^.title)]
        br_ []
        label_ $ do
          "Group" >> br_ []
          input_ [type_ "text", name_ "group",
                  autocomplete_ "off",
                  value_ (category^.group_)]
        br_ []
        label_ $ do
          "Status" >> br_ []
          select_ [name_ "status", autocomplete_ "off"] $ do
            option_ [value_ "finished"] "Complete"
              & selectedIf (category^.status == CategoryFinished)
            option_ [value_ "mostly-done"] "Mostly done/usable"
              & selectedIf (category^.status == CategoryMostlyDone)
            option_ [value_ "wip"] "Work in progress"
              & selectedIf (category^.status == CategoryWIP)
            option_ [value_ "stub"] "Stub"
              & selectedIf (category^.status == CategoryStub)
        br_ []
        label_ $ do
          input_ [type_ "checkbox", name_ "pros-cons-enabled",
                  autocomplete_ "off"]
            & checkedIf (category^.prosConsEnabled)
          "Pros/cons enabled"
        br_ []
        label_ $ do
          input_ [type_ "checkbox", name_ "ecosystem-enabled",
                  autocomplete_ "off"]
            & checkedIf (category^.ecosystemEnabled)
          "“Ecosystem” field enabled"
        br_ []
        input_ [type_ "submit", value_ "Save"]
        button "Cancel" [] $
          JS.switchSection (this, "normal" :: Text)

renderCategoryNotes :: MonadIO m => Category -> HtmlT m ()
renderCategoryNotes category = cached (CacheCategoryNotes (category^.uid)) $ do
  let thisId = "category-notes-" <> uidToText (category^.uid)
      this   = JS.selectId thisId
  div_ [id_ thisId, class_ "category-notes"] $ do

    section "normal" [shown, noScriptShown] $ do
      div_ [class_ "notes-like"] $ do
        if markdownNull (category^.notes)
          then p_ "write something here!"
          else toHtml (category^.notes)
      textButton "edit description" $
        JS.switchSection (this, "editing" :: Text) <>
        JS.focusOn [(this `JS.selectSection` "editing")
                    `JS.selectChildren`
                    JS.selectClass "editor"]

    section "editing" [] $ do
      contents <- if markdownNull (category^.notes)
        then liftIO $ toMarkdownBlock <$>
               T.readFile "static/category-notes-template.md"
        else return (category^.notes)
      markdownEditor
        [rows_ "10", class_ " editor "]
        contents
        (\val -> JS.submitCategoryNotes
                   (this, category^.uid, category^.notes.mdText, val))
        (JS.switchSection (this, "normal" :: Text))
        "or press Ctrl+Enter to save"

renderCategory :: MonadIO m => Category -> HtmlT m ()
renderCategory category = cached (CacheCategory (category^.uid)) $ do
  div_ [class_ "category", id_ (categoryNodeId category)] $ do
    renderCategoryInfo 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)

{- Note [enabled sections]
~~~~~~~~~~~~~~~~~~~~~~~~~~

Categories have flags that enable/disable showing some sections of the items (currently pros/cons and ecosystem); this is done because for some items (like books, or people) “ecosystem” might not make any sense, and pros/cons don't make sense for categories that contain diverse items.

When we change those flags (by editing category info), we want to update the way items are shown (without reloading the page). So, if the “show ecosystem” flag has been set and we unset it, we want to hide the ecosystem section in all items belonging to the category. This happens in 'JS.submitCategoryInfo'.

If the category has showing pros/cons (or ecosystem, or both) disabled, we have to render traits and ecosystem as hidden (we can't just not render them at all, because then we wouldn't be able to un-hide them). How could we do it? If we do it in 'renderItemTraits' or 'renderItemEcosystem', this would mean that cached versions of traits/ecosystem would have to be rerendered whenever prosConsEnabled/ecosystemEnabled is changed. So, instead we do a somewhat inelegant thing: we wrap traits/ecosystem into yet another <div>, and set “display:none” on it. 'JS.submitCategoryInfo' operates on those <div>s.
-}

-- TODO: perhaps use jQuery Touch Punch or something to allow dragging items
-- instead of using arrows? Touch Punch works on mobile, too
renderItem :: MonadIO m => Category -> Item -> HtmlT m ()
renderItem category item = cached (CacheItem (item^.uid)) $ do
  -- The id is used for links in feeds, and for anchor links
  div_ [id_ (itemNodeId item), class_ "item"] $ do
    renderItemInfo category item
    let bg = hueToLightColor $ getItemHue category item
    div_ [class_ "item-body", style_ ("background-color:" <> bg)] $ do
      -- See Note [enabled sections]
      renderItemDescription item
      hiddenIf (not (category^.prosConsEnabled)) $
        div_ [class_ "pros-cons-wrapper"] $
          renderItemTraits item
      hiddenIf (not (category^.ecosystemEnabled)) $
        div_ [class_ "ecosystem-wrapper"] $
          renderItemEcosystem item
      renderItemNotes category item

-- TODO: warn when a library isn't on Hackage but is supposed to be

renderItemTitle :: (MonadIO m, MonadThrow m) => Item -> HtmlT m ()
renderItemTitle item =
  mustache "item-title" $ A.object [
    "item" A..= item ]

-- TODO: give a link to oldest available docs when the new docs aren't there
renderItemInfo :: (MonadIO m, MonadThrow m) => Category -> Item -> HtmlT m ()
renderItemInfo cat item = cached (CacheItemInfo (item^.uid)) $ do
  let itemkindname :: Text
      itemkindname = case item^.kind of
        Library{} -> "library"
        Tool{} -> "tool"
        Other{} -> "other"
  mustache "item-info" $ A.object [
    "category" A..= cat,
    "item" A..= item,
    "link_to_item" A..= itemLink cat item,
    "possible_kinds" A..= do
        kindname <- ["library", "tool", "other"]
        return $ A.object [
          "name" A..= kindname,
          "caption" A..= over _head toUpper kindname,
          "selected" A..= (itemkindname == kindname) ],
    "item_no_group" A..= isNothing (item^.group_),
    "item_color" A..= A.object [
      "dark"  A..= hueToDarkColor (getItemHue cat item),
      "light" A..= hueToLightColor (getItemHue cat item) ] ]

renderItemDescription :: MonadIO m => Item -> HtmlT m ()
renderItemDescription item = cached (CacheItemDescription (item^.uid)) $
  mustache "item-description" $ A.object [
    "item" A..= item ]

renderItemEcosystem :: MonadIO m => Item -> HtmlT m ()
renderItemEcosystem item = cached (CacheItemEcosystem (item^.uid)) $ do
  let thisId = "item-ecosystem-" <> uidToText (item^.uid)
      this   = JS.selectId thisId
  div_ [id_ thisId, class_ "item-ecosystem"] $ do

    section "normal" [shown, noScriptShown] $ do
      strong_ "Ecosystem"
      emptySpan "0.5em"
      imgButton "edit ecosystem" "/pencil.svg"
        [style_ "width:12px;opacity:0.5"] $
        JS.switchSection (this, "editing" :: Text) <>
        JS.focusOn [(this `JS.selectSection` "editing")
                    `JS.selectChildren`
                    JS.selectClass "editor"]
      unless (markdownNull (item^.ecosystem)) $
        toHtml (item^.ecosystem)

    section "editing" [] $ do
      strong_ "Ecosystem"
      emptySpan "0.5em"
      imgButton "quit editing ecosystem" "/pencil.svg"
        [style_ "width:12px;opacity:0.5"] $
        JS.switchSection (this, "normal" :: Text)
      markdownEditor
        [rows_ "3", class_ " editor "]
        (item^.ecosystem)
        (\val -> JS.submitItemEcosystem
                   (this, item^.uid, item^.ecosystem.mdText, val))
        (JS.switchSection (this, "normal" :: Text))
        "or press Ctrl+Enter to save"

renderItemTraits :: MonadIO m => Item -> HtmlT m ()
renderItemTraits item = cached (CacheItemTraits (item^.uid)) $ do
  div_ [class_ "item-traits"] $ do
    div_ [class_ "traits-groups-container"] $ do
      div_ [class_ "traits-group"] $ do
        strong_ "Pros"
        this <- thisNode
        emptySpan "0.5em"
        sectionSpan "normal" [shown, noScriptShown] $ do
          imgButton "edit pros" "/pencil.svg"
            [style_ "width:12px;opacity:0.5"] $
            JS.switchSectionsEverywhere (this, "editable" :: Text)
        sectionSpan "editable" [] $ do
          imgButton "quit editing pros" "/pencil.svg"
            [style_ "width:12px;opacity:0.5"] $
            JS.switchSectionsEverywhere (this, "normal" :: Text)
        -- We can't use 'thisNode' inside <ul> because it creates a <span>
        -- and only <li> elements can be children of <ul>
        listUid <- randomLongUid
        ul_ [uid_ listUid] $
          mapM_ (renderTrait (item^.uid)) (item^.pros)
        section "editable" [] $ do
          smallMarkdownEditor
            [rows_ "3", placeholder_ "add pro"]
            (toMarkdownInline "")
            (\val -> JS.addPro (JS.selectUid listUid, item^.uid, val) <>
                     JS.assign val ("" :: Text))
            Nothing
            "press Ctrl+Enter or Enter to add"
          textButton "edit off" $
            JS.switchSectionsEverywhere(this, "normal" :: Text)

      div_ [class_ "traits-group"] $ do
        strong_ "Cons"
        this <- thisNode
        emptySpan "0.5em"
        sectionSpan "normal" [shown, noScriptShown] $ do
          imgButton "edit cons" "/pencil.svg"
            [style_ "width:12px;opacity:0.5"] $
            JS.switchSectionsEverywhere (this, "editable" :: Text)
        sectionSpan "editable" [] $ do
          imgButton "quit editing cons" "/pencil.svg"
            [style_ "width:12px;opacity:0.5"] $
            JS.switchSectionsEverywhere (this, "normal" :: Text)
        listUid <- randomLongUid
        ul_ [uid_ listUid] $
          mapM_ (renderTrait (item^.uid)) (item^.cons)
        section "editable" [] $ do
          smallMarkdownEditor
            [rows_ "3", placeholder_ "add con"]
            (toMarkdownInline "")
            (\val -> JS.addCon (JS.selectUid listUid, item^.uid, val) <>
                     JS.assign val ("" :: Text))
            Nothing
            "press Ctrl+Enter or Enter to add"
          textButton "edit off" $
            JS.switchSectionsEverywhere(this, "normal" :: Text)

renderTrait :: MonadIO m => Uid Item -> Trait -> HtmlT m ()
renderTrait itemUid trait =
  mustache "trait" $ A.object [
    "item"  A..= A.object [
        "uid" A..= itemUid ],
    "trait" A..= trait ]

-- TODO: automatically provide links to modules in Markdown (and have a
-- database of modules or something)

-- TODO: [very-easy] write about the all-is-text extension
-- TODO: [easy] write that arrows are for arranging stuff, not upvoting

-- TODO: [easy] add Hayoo search, Hoogle search, and Hackage search shortcut
-- boxes

-- TODO: when searching, show links to package, main modules, etc before all
-- categories

-- TODO: attach TODOs (“fix grammar”, etc) to items and categories (or should
-- people instead just write “TODO fix grammar” in description and then such
-- things could be displayed in gray font and also there'd be an
-- automatically updated list of TODOs somewhere?)

renderItemNotes :: MonadIO m => Category -> Item -> HtmlT m ()
renderItemNotes category item = cached (CacheItemNotes (item^.uid)) $ do
  -- Don't change this ID, it's used in e.g. 'JS.expandHash'
  let thisId = "item-notes-" <> uidToText (item^.uid)
      this   = JS.selectId thisId
  editingSectionUid <- randomLongUid
  div_ [id_ thisId, class_ "item-notes"] $ do
    let notesLink = categoryLink category <> "#" <> thisId
    a_ [href_ notesLink] $
      strong_ "Notes"

    let renderTree :: Monad m => Forest ([MD.Node], Text) -> HtmlT m ()
        renderTree [] = return ()
        renderTree xs = ul_ $ do
          for_ xs $ \(Node (is, id') children) -> li_ $ do
            let handler = fromJS (JS.expandItemNotes [item^.uid])
                -- The link has to be absolute because sometimes we are
                -- looking at items from pages different from the proper
                -- category pages (e.g. if a search from the main page
                -- returned several items from different categories, and the
                -- user is looking at those items' notes without leaving the
                -- search page). Well, actually it doesn't happen yet because
                -- there's no search (or rather, there is search but it
                -- doesn't return items, only categories); however, it might
                -- start happening and then it's better to be prepared.
                fullLink = categoryLink category <> "#" <> id'
            a_ [href_ fullLink, onclick_ handler] $
              toHtmlRaw (renderMD is)
            renderTree children
    let renderTOC = do
          let toc = item^.notes.mdTOC
          div_ [class_ "notes-toc"] $ do
            if null toc
              then p_ (emptySpan "1.5em" >> "<notes are empty>")
              else renderTree toc

    section "collapsed" [shown] $ do
      textButton "expand notes" $
        JS.expandItemNotes [item^.uid]
      renderTOC

    section "expanded" [noScriptShown] $ do
      textareaUid <- randomLongUid
      contents <- if markdownNull (item^.notes)
        then liftIO $ T.readFile "static/item-notes-template.md"
        else return (item^.notes.mdText)
      let buttons = do
            textButton "collapse notes" $
              JS.switchSection (this, "collapsed" :: Text)
            emptySpan "1em"
            textButton "edit notes" $
              -- See Note [dynamic interface]
              JS.makeItemNotesEditor (
                   this, JS.selectUid editingSectionUid,
                   textareaUid,
                   -- See Note [blurb diffing]
                   markdownNull (item^.notes),
                   contents,
                   item^.uid) <>
              JS.switchSection (this, "editing" :: Text) <>
              JS.autosizeTextarea [JS.selectUid textareaUid] <>
              JS.focusOn [JS.selectUid textareaUid]
      buttons
      renderTOC
      div_ [class_ "notes-like"] $ do
        if markdownNull (item^.notes)
          then p_ "add something!"
          else toHtml (item^.notes)
      unless (markdownNull (item^.notes)) $
        buttons
      -- TODO: [easy] the lower “hide notes” should scroll back to item when
      -- the notes are closed (but don't scroll if it's already visible after
      -- the notes have been hidden)

    section "editing" [uid_ editingSectionUid] $
      return ()

renderItemForFeed
  :: (MonadIO m, MonadThrow m)
  => Category -> Item -> HtmlT m ()
renderItemForFeed category item = do
  h1_ $ renderItemTitle item
  unless (markdownNull (item^.description)) $
    toHtml (item^.description)
  when (category^.prosConsEnabled) $ do
    h2_ "Pros"
    ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.pros)
    h2_ "Cons"
    ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.cons)
  when (category^.ecosystemEnabled) $ do
    unless (markdownNull (item^.ecosystem)) $ do
      h2_ "Ecosystem"
      toHtml (item^.ecosystem)
  -- TODO: include .notes-like style here? otherwise the headers are too big
  unless (markdownNull (item^.notes)) $ do
    h2_ "Notes"
    toHtml (item^.notes)

-- Utils

onPageLoad :: Monad m => JS -> HtmlT m ()
onPageLoad js = script_ $ T.format "$(document).ready(function(){{}});" [js]

emptySpan :: Monad m => Text -> HtmlT m ()
emptySpan w = span_ [style_ ("margin-left:" <> w)] mempty

-- Use inputValue to get the value (works with input_ and textarea_)
onEnter :: JS -> Attribute
onEnter handler = onkeydown_ $
  T.format "if (event.keyCode == 13 || event.keyCode == 10)\
           \ {{} return false;}\n" [handler]

onCtrlEnter :: JS -> Attribute
onCtrlEnter handler = onkeydown_ $
  T.format "if ((event.keyCode == 13 || event.keyCode == 10) &&\
           \    (event.metaKey || event.ctrlKey))\
           \ {{} return false;}\n" [handler]

onEscape :: JS -> Attribute
onEscape handler = onkeydown_ $
  T.format "if (event.keyCode == 27)\
           \ {{} return false;}\n" [handler]

textInput :: Monad m => [Attribute] -> HtmlT m ()
textInput attrs = input_ (type_ "text" : attrs)

inputValue :: JS
inputValue = JS "this.value"

clearInput :: JS
clearInput = JS "this.value = '';"

onFormSubmit :: (JS -> JS) -> Attribute
onFormSubmit f = onsubmit_ $ T.format "{} return false;" [f (JS "this")]

button :: Monad m => Text -> [Attribute] -> JS -> HtmlT m ()
button value attrs handler =
  input_ (type_ "button" : value_ value : onclick_ handler' : attrs)
  where
    handler' = fromJS handler

-- A text button looks like “[cancel]”
textButton
  :: Monad m
  => Text         -- ^ Button text
  -> JS           -- ^ Onclick handler
  -> HtmlT m ()
textButton caption (JS handler) =
  span_ [class_ "text-button"] $
    -- “#” is used instead of javascript:void(0) because the latter is slow
    -- in Firefox (at least for me – tested with Firefox 43 on Arch Linux)
    a_ [href_ "#", onclick_ (handler <> "return false;")]
       (toHtml caption)

-- So far all icons used here have been from <https://useiconic.com/open/>
imgButton :: Monad m => Text -> Url -> [Attribute] -> JS -> HtmlT m ()
imgButton alt src attrs (JS handler) =
  a_ [href_ "#", onclick_ (handler <> "return false;")]
     (img_ (src_ src : alt_ alt : title_ alt : attrs))

mkLink :: Monad m => HtmlT m a -> Url -> HtmlT m a
mkLink x src = a_ [href_ src] x

selectedIf :: With w => Bool -> w -> w
selectedIf p x = if p then with x [selected_ "selected"] else x

checkedIf :: With w => Bool -> w -> w
checkedIf p x = if p then with x [checked_] else x

hiddenIf :: With w => Bool -> w -> w
hiddenIf p x = if p then with x [style_ "display:none;"] else x

markdownEditor
  :: MonadIO m
  => [Attribute]
  -> MarkdownBlock  -- ^ Default text
  -> (JS -> JS)     -- ^ “Submit” handler, receiving the contents of the editor
  -> JS             -- ^ “Cancel” handler
  -> Text           -- ^ Instruction (e.g. “press Ctrl+Enter to save”)
  -> HtmlT m ()
markdownEditor attr (view mdText -> s) submit cancel instr = do
  textareaUid <- randomLongUid
  let val = JS $ T.format "document.getElementById(\"{}\").value" [textareaUid]
  -- Autocomplete has to be turned off thanks to
  -- <http://stackoverflow.com/q/8311455>.
  textarea_ ([uid_ textareaUid,
              autocomplete_ "off",
              class_ "big fullwidth",
              onCtrlEnter (submit val),
              onEscape (JS.assign val s <> cancel) ]
             ++ attr) $
    toHtml s
  button "Save" [] $
    submit val
  emptySpan "6px"
  button "Cancel" [] $
    JS.assign val s <>
    cancel
  emptySpan "6px"
  span_ [class_ "edit-field-instruction"] (toHtml instr)
  a_ [href_ "/markdown", target_ "_blank"] "Markdown"

smallMarkdownEditor
  :: MonadIO m
  => [Attribute]
  -> MarkdownInline -- ^ Default text
  -> (JS -> JS)     -- ^ “Submit” handler, receiving the contents of the editor
  -> Maybe JS       -- ^ “Cancel” handler (if “Cancel” is needed)
  -> Text           -- ^ Instruction (e.g. “press Enter to add”)
  -> HtmlT m ()
smallMarkdownEditor attr (view mdText -> s) submit mbCancel instr = do
  textareaId <- randomLongUid
  let val = JS $ T.format "document.getElementById(\"{}\").value" [textareaId]
  textarea_ ([class_ "fullwidth", uid_ textareaId, autocomplete_ "off"] ++
             [onEnter (submit val)] ++
             [onEscape cancel | Just cancel <- [mbCancel]] ++
             attr) $
    toHtml s
  br_ []
  for_ mbCancel $ \cancel -> do
    textButton "cancel" $
      JS.assign val s <>
      cancel
  span_ [style_ "float:right"] $ do
    span_ [class_ "edit-field-instruction"] (toHtml instr)
    a_ [href_ "/markdown", target_ "_blank"] "Markdown"

thisNode :: MonadIO m => HtmlT m JQuerySelector
thisNode = do
  uid' <- randomLongUid
  -- If the class name ever changes, fix 'JS.moveNodeUp' and
  -- 'JS.moveNodeDown'.
  span_ [uid_ uid', class_ "dummy"] mempty
  return (JS.selectParent (JS.selectUid uid'))

itemNodeId :: Item -> Text
itemNodeId item = "item-" <> uidToText (item^.uid)

categoryNodeId :: Category -> Text
categoryNodeId category = "category-" <> uidToText (category^.uid)

-- TODO: another absolute link to get rid of [absolute-links]
categoryLink :: Category -> Url
categoryLink category = "/haskell/" <> categorySlug category

itemLink :: Category -> Item -> Url
itemLink category item =
  T.format "/haskell/{}#{}" (categorySlug category, itemNodeId item)

-- See Note [show-hide]; wheh changing these, also look at 'JS.switchSection'.
shown, noScriptShown :: Attribute
shown          = class_ " shown "
noScriptShown  = class_ " noscript-shown "

-- See Note [show-hide]
section
  :: Monad m
  => Text           -- ^ Section name (or names)
  -> [Attribute]    -- ^ Additional attributes
  -> HtmlT m ()     -- ^ Content of the section
  -> HtmlT m ()
section t attrs = div_ (class_ (t <> " section ") : attrs)

-- See Note [show-hide]
sectionSpan
  :: Monad m
  => Text           -- ^ Section name (or names)
  -> [Attribute]    -- ^ Additional attributes
  -> HtmlT m ()     -- ^ Content of the section
  -> HtmlT m ()
sectionSpan t attrs = span_ (class_ (t <> " section ") : attrs)

{-
TODO: warn about how one shouldn't write @foo("{{bar}}")@ in templates, because a newline in 'bar' directly after the quote will mess things up. Write @foo({{{%js bar}}})@ instead.
-}
mustache :: MonadIO m => PName -> A.Value -> HtmlT m ()
mustache f v = do
  let functions = M.fromList [
        ("selectIf", \[x] -> if x == A.Bool True
            then return (A.String "selected")
            else return A.Null),
        ("js", \[x] -> return $
            A.String . T.toStrict . TL.decodeUtf8 . A.encode $ x),
        ("trace", \xs -> do
            mapM_ (BS.putStrLn . A.encodePretty) xs
            return A.Null) ]
  widgets <- readWidgets
  let templates = [(tname, t) | (HTML_ tname, t) <- widgets]
  when (null templates) $
    error "View.mustache: no HTML templates found in templates/"
  parsed <- for templates $ \(tname, t) -> do
    let pname = fromString (T.unpack tname)
    case compileMustacheText pname (T.toLazy t) of
      Left e -> error $ printf "View.mustache: when parsing %s: %s"
                               tname (parseErrorPretty e)
      Right template -> return template
  let combined = (Semigroup.sconcat (NonEmpty.fromList parsed)) {
                   templateActual = f }
  (rendered, warnings) <- liftIO $ renderMustacheM functions combined v
  when (not (null warnings)) $
    error $ printf "View.mustache: warnings when rendering %s:\n%s"
                   (unPName f) (unlines warnings)
  toHtmlRaw rendered

data SectionType
  = HTML_ Text | JS_ | CSS_ | Description_ | Note_ Text

-- | Used to turn collected section lines back into a section.
--
-- * Trims surrounding blank lines
-- * Doesn't append a newline when there's only one line
--   (useful for inline partials)
unlinesSection :: [Text] -> Text
unlinesSection = unlines' . dropWhile T.null . dropWhileEnd T.null
  where
    unlines' []  = ""
    unlines' [x] = x
    unlines' xs  = T.unlines xs

readWidget :: MonadIO m => FilePath -> m [(SectionType, Text)]
readWidget fp = liftIO $ do
  s <- T.readFile fp
  let isDivide line = (T.all (== '=') line || T.all (== '-') line) &&
                      T.length line >= 20
  let go (x:y:[]) = [(T.strip (last x), unlinesSection y)]
      go (x:y:xs) = (T.strip (last x), unlinesSection (init y)) : go (y : xs)
      go _ = error $ "View.readWidget: couldn't read " ++ fp
  let sections = go (splitWhen isDivide (T.lines s))
  let sectionTypeP :: Parser SectionType
      sectionTypeP = choice [
        do string "HTML"
           HTML_ <$> choice [
             string ": " >> (T.pack <$> some anyChar),
             return (T.pack (takeBaseName fp)) ],
        string "JS" $> JS_,
        string "CSS" $> CSS_,
        string "Description" $> Description_,
        do string "Note ["
           Note_ . T.pack <$> someTill anyChar (char ']') ]
  let parseSectionType t = case parse (sectionTypeP <* eof) fp t of
        Right x -> x
        Left e -> error $ printf "invalid section name: '%s'\n%s"
                          t (parseErrorPretty e)
  return $ over (each._1) parseSectionType sections

readWidgets :: MonadIO m => m [(SectionType, Text)]
readWidgets = liftIO $ do
  let isWidget = F.extension F.==? ".widget"
  files <- F.find F.always isWidget "templates/"
  concat <$> mapM readWidget files

getJS :: MonadIO m => m Text
getJS = do
  widgets <- readWidgets
  let js = [t | (JS_, t) <- widgets]
  return (T.concat js)

getCSS :: MonadIO m => m Text
getCSS = do
  widgets <- readWidgets
  let css = [t | (CSS_, t) <- widgets]
  return (T.concat css)