{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | HTML & CSS
module Neuron.Zettelkasten.View where

import Clay hiding (head, id, ms, reverse, s, type_)
import qualified Clay as C
import Data.Foldable (maximum)
import Data.Tree (Tree (..))
import Lucid
import Neuron.Version (neuronVersionFull)
import Neuron.Zettelkasten.Config
import Neuron.Zettelkasten.Graph
import Neuron.Zettelkasten.ID (ZettelID (..), zettelIDSourceFileName)
import Neuron.Zettelkasten.Link (linkActionExt)
import Neuron.Zettelkasten.Link.Action (LinkTheme (..))
import Neuron.Zettelkasten.Link.View (renderZettelLink)
import Neuron.Zettelkasten.Markdown (neuronMMarkExts)
import Neuron.Zettelkasten.Meta
import Neuron.Zettelkasten.Route
import Neuron.Zettelkasten.Store
import Neuron.Zettelkasten.Type
import Relude
import qualified Rib
import Rib.Extra.CSS (mozillaKbdStyle)
import qualified Rib.Parser.MMark as MMark
import Text.MMark (useExtensions)
import Text.Pandoc.Highlighting (styleToCss, tango)

renderRouteHead :: Monad m => Config -> Route store graph a -> store -> HtmlT m ()
renderRouteHead :: Config -> Route store graph a -> store -> HtmlT m ()
renderRouteHead config :: Config
config r :: Route store graph a
r val :: store
val = do
  [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
httpEquiv_ "Content-Type", Text -> Attribute
content_ "text/html; charset=utf-8"]
  [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
name_ "viewport", Text -> Attribute
content_ "width=device-width, initial-scale=1"]
  HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
title_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> HtmlT m ()) -> Text -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Config -> store -> Route store graph a -> Text
forall store graph a.
Config -> store -> Route store graph a -> Text
routeTitle Config
config store
val Route store graph a
r
  [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
link_ [Text -> Attribute
rel_ "shortcut icon", Text -> Attribute
href_ "https://raw.githubusercontent.com/srid/neuron/master/assets/logo.ico"]
  case Route store graph a
r of
    Route_IndexRedirect ->
      HtmlT m ()
forall a. Monoid a => a
mempty
    _ -> do
      OpenGraph -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (OpenGraph -> HtmlT m ()) -> OpenGraph -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Config -> store -> Route store graph a -> OpenGraph
forall store graph a.
Config -> store -> Route store graph a -> OpenGraph
routeOpenGraph Config
config store
val Route store graph a
r
      [Attribute] -> String -> HtmlT m ()
forall arg result. TermRaw arg result => arg -> result
style_ [Text -> Attribute
type_ "text/css"] (String -> HtmlT m ()) -> String -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Style -> String
styleToCss Style
tango

renderRouteBody :: Monad m => Config -> Route store graph a -> (store, graph) -> HtmlT m ()
renderRouteBody :: Config -> Route store graph a -> (store, graph) -> HtmlT m ()
renderRouteBody config :: Config
config r :: Route store graph a
r val :: (store, graph)
val = do
  case Route store graph a
r of
    Route_ZIndex ->
      (ZettelStore, ZettelGraph) -> HtmlT m ()
forall (m :: * -> *).
Monad m =>
(ZettelStore, ZettelGraph) -> HtmlT m ()
renderIndex (store, graph)
(ZettelStore, ZettelGraph)
val
    Route_Zettel zid :: ZettelID
zid ->
      Config -> (ZettelStore, ZettelGraph) -> ZettelID -> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Config -> (ZettelStore, ZettelGraph) -> ZettelID -> HtmlT m ()
renderZettel Config
config (store, graph)
(ZettelStore, ZettelGraph)
val ZettelID
zid
    Route_IndexRedirect ->
      [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [Text -> Attribute
httpEquiv_ "Refresh", Text -> Attribute
content_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ "0; url=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Route ZettelStore ZettelGraph () -> Text
forall (r :: * -> *) a. IsRoute r => r a -> Text
Rib.routeUrlRel Route ZettelStore ZettelGraph ()
Route_ZIndex]

renderIndex :: Monad m => (ZettelStore, ZettelGraph) -> HtmlT m ()
renderIndex :: (ZettelStore, ZettelGraph) -> HtmlT m ()
renderIndex (store :: ZettelStore
store, graph :: ZettelGraph
graph) = do
  [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
h1_ [Text -> Attribute
class_ "header"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ "Zettel Index"
  [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "z-index"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
    -- Cycle detection.
    case ZettelGraph -> Either (NonEmpty ZettelID) [ZettelID]
topSort ZettelGraph
graph of
      Left (NonEmpty ZettelID -> [ZettelID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [ZettelID]
cyc) -> [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui orange segment"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
        HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
h2_ "Cycle detected"
        [ZettelID] -> (ZettelID -> HtmlT m ()) -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ZettelID]
cyc ((ZettelID -> HtmlT m ()) -> HtmlT m ())
-> (ZettelID -> HtmlT m ()) -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ \zid :: ZettelID
zid ->
          HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
li_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ LinkTheme -> ZettelStore -> ZettelID -> HtmlT m ()
forall (m :: * -> *).
Monad m =>
LinkTheme -> ZettelStore -> ZettelID -> HtmlT m ()
renderZettelLink LinkTheme
LinkTheme_Default ZettelStore
store ZettelID
zid
      _ -> HtmlT m ()
forall a. Monoid a => a
mempty
    let clusters :: [[ZettelID]]
clusters = [NonEmpty ZettelID] -> [[ZettelID]]
forall b (t :: * -> *). (Ord b, Foldable t) => [t b] -> [[b]]
sortMothers ([NonEmpty ZettelID] -> [[ZettelID]])
-> [NonEmpty ZettelID] -> [[ZettelID]]
forall a b. (a -> b) -> a -> b
$ ZettelGraph -> [NonEmpty ZettelID]
zettelClusters ZettelGraph
graph
    HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
p_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
      "There " HtmlT m () -> HtmlT m () -> HtmlT m ()
forall a. Semigroup a => a -> a -> a
<> HtmlT m () -> HtmlT m () -> Int -> HtmlT m ()
forall a p.
(Eq a, Num a, Semigroup p, IsString p, Show a) =>
p -> p -> a -> p
countNounBe "cluster" "clusters" ([[ZettelID]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[ZettelID]]
clusters) HtmlT m () -> HtmlT m () -> HtmlT m ()
forall a. Semigroup a => a -> a -> a
<> " in the Zettelkasten graph. "
      "Each cluster is rendered as a forest, with their roots (mother zettels) highlighted."
    [[ZettelID]] -> ([ZettelID] -> HtmlT m ()) -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[ZettelID]]
clusters (([ZettelID] -> HtmlT m ()) -> HtmlT m ())
-> ([ZettelID] -> HtmlT m ()) -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ \zids :: [ZettelID]
zids ->
      [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui piled segment"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
        let forest :: Forest ZettelID
forest = [ZettelID] -> ZettelGraph -> Forest ZettelID
dfsForestFrom [ZettelID]
zids ZettelGraph
graph
        -- Forest of zettels, beginning with mother vertices.
        HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
ul_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
renderForest Bool
True Maybe Int
forall a. Maybe a
Nothing LinkTheme
LinkTheme_Default ZettelStore
store ZettelGraph
graph Forest ZettelID
forest
  where
    -- Sort clusters with newer mother zettels appearing first.
    sortMothers :: [t b] -> [[b]]
sortMothers ms :: [t b]
ms = [[b]] -> [[b]]
forall a. [a] -> [a]
reverse ([[b]] -> [[b]]) -> [[b]] -> [[b]]
forall a b. (a -> b) -> a -> b
$ ([b] -> b) -> [[b]] -> [[b]]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn [b] -> b
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([[b]] -> [[b]]) -> [[b]] -> [[b]]
forall a b. (a -> b) -> a -> b
$ (t b -> [b]) -> [t b] -> [[b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([b] -> [b]
forall a. [a] -> [a]
reverse ([b] -> [b]) -> (t b -> [b]) -> t b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> [b]
forall a. Ord a => [a] -> [a]
sort ([b] -> [b]) -> (t b -> [b]) -> t b -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) [t b]
ms
    countNounBe :: p -> p -> a -> p
countNounBe noun :: p
noun nounPlural :: p
nounPlural = \case
      1 -> "is 1 " p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
noun
      n :: a
n -> "are " p -> p -> p
forall a. Semigroup a => a -> a -> a
<> a -> p
forall b a. (Show a, IsString b) => a -> b
show a
n p -> p -> p
forall a. Semigroup a => a -> a -> a
<> " " p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
nounPlural

renderZettel :: forall m. Monad m => Config -> (ZettelStore, ZettelGraph) -> ZettelID -> HtmlT m ()
renderZettel :: Config -> (ZettelStore, ZettelGraph) -> ZettelID -> HtmlT m ()
renderZettel config :: Config
config@Config {..} (store :: ZettelStore
store, graph :: ZettelGraph
graph) zid :: ZettelID
zid = do
  let Zettel {..} = ZettelID -> ZettelStore -> Zettel
lookupStore ZettelID
zid ZettelStore
store
      zettelTags :: Maybe [Text]
zettelTags = MMark -> Maybe Meta
getMeta MMark
zettelContent Maybe Meta -> (Meta -> Maybe [Text]) -> Maybe [Text]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Meta -> Maybe [Text]
tags
  [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "zettel-view"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
    [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui raised segment"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
      [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
h1_ [Text -> Attribute
class_ "header"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
zettelTitle
      [Text] -> HtmlT m ()
forall (m :: * -> *). Monad m => [Text] -> HtmlT m ()
renderTags ([Text] -> HtmlT m ()) -> Maybe [Text] -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` Maybe [Text]
zettelTags
      let mmarkExts :: [Extension]
mmarkExts = Config -> [Extension]
neuronMMarkExts Config
config
      MMark -> HtmlT m ()
forall (m :: * -> *). Monad m => MMark -> HtmlT m ()
MMark.render (MMark -> HtmlT m ()) -> MMark -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ [Extension] -> MMark -> MMark
useExtensions (ZettelStore -> Extension
linkActionExt ZettelStore
store Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: [Extension]
mmarkExts) MMark
zettelContent
    [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui inverted teal top attached connections segment"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
      [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui two column grid"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
        [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "column"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
          [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui header"] "Connections"
          let forest :: Forest ZettelID
forest = ZettelID -> Forest ZettelID -> Forest ZettelID
forall a. (Show a, Eq a) => a -> [Tree a] -> [Tree a]
obviateRootUnlessForest ZettelID
zid (Forest ZettelID -> Forest ZettelID)
-> Forest ZettelID -> Forest ZettelID
forall a b. (a -> b) -> a -> b
$ [ZettelID] -> ZettelGraph -> Forest ZettelID
dfsForestFrom [ZettelID
zid] ZettelGraph
graph
          HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
ul_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
renderForest Bool
True (Int -> Maybe Int
forall a. a -> Maybe a
Just 2) LinkTheme
LinkTheme_Simple ZettelStore
store ZettelGraph
graph Forest ZettelID
forest
        [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "column"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
          [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui header"] "Navigate up"
          let forestB :: Forest ZettelID
forestB = ZettelID -> Forest ZettelID -> Forest ZettelID
forall a. (Show a, Eq a) => a -> [Tree a] -> [Tree a]
obviateRootUnlessForest ZettelID
zid (Forest ZettelID -> Forest ZettelID)
-> Forest ZettelID -> Forest ZettelID
forall a b. (a -> b) -> a -> b
$ ZettelID -> ZettelGraph -> Forest ZettelID
dfsForestBackwards ZettelID
zid ZettelGraph
graph
          HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
ul_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
            Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
renderForest Bool
True Maybe Int
forall a. Maybe a
Nothing LinkTheme
LinkTheme_Simple ZettelStore
store ZettelGraph
graph Forest ZettelID
forestB
    [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui inverted black bottom attached footer segment"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
      [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui three column grid"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
        [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "center aligned column"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
          [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ ".", Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ "/"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
fa "fas fa-home"
        [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "center aligned column"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
          Maybe Text -> (Text -> HtmlT m ()) -> HtmlT m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
editUrl ((Text -> HtmlT m ()) -> HtmlT m ())
-> (Text -> HtmlT m ()) -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ \urlPrefix :: Text
urlPrefix ->
            [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Text
urlPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ZettelID -> Text
zettelIDSourceFileName ZettelID
zid, Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ "Edit this Zettel"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
fa "fas fa-edit"
        [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "center aligned column"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
          [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (Route ZettelStore ZettelGraph () -> Text
forall (r :: * -> *) a. IsRoute r => r a -> Text
Rib.routeUrlRel Route ZettelStore ZettelGraph ()
Route_ZIndex), Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ "All Zettels (z-index)"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$
            Text -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
fa "fas fa-tree"
    [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui one column grid footer-version"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
      [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "center aligned column"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
        HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
p_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
          "Generated by "
          [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ "https://github.com/srid/neuron"] "Neuron"
          " "
          HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
code_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml @Text Text
neuronVersionFull

renderTags :: Monad m => [Text] -> HtmlT m ()
renderTags :: [Text] -> HtmlT m ()
renderTags tags :: [Text]
tags = do
  [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui tiny labels"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
    [Text] -> (Text -> HtmlT m ()) -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
tags ((Text -> HtmlT m ()) -> HtmlT m ())
-> (Text -> HtmlT m ()) -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ \tag :: Text
tag -> do
      [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui lightgrey label"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml @Text Text
tag
  [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ "ui divider"] (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ HtmlT m ()
forall a. Monoid a => a
mempty

-- | Font awesome element
fa :: Monad m => Text -> HtmlT m ()
fa :: Text -> HtmlT m ()
fa k :: Text
k = (HtmlT m () -> HtmlT m ())
-> [Attribute] -> HtmlT m () -> HtmlT m ()
forall a. With a => a -> [Attribute] -> a
with HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
i_ [Text -> Attribute
class_ Text
k] HtmlT m ()
forall a. Monoid a => a
mempty

renderForest ::
  Monad m =>
  Bool ->
  Maybe Int ->
  LinkTheme ->
  ZettelStore ->
  ZettelGraph ->
  [Tree ZettelID] ->
  HtmlT m ()
renderForest :: Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
renderForest isRoot :: Bool
isRoot maxLevel :: Maybe Int
maxLevel ltheme :: LinkTheme
ltheme s :: ZettelStore
s g :: ZettelGraph
g trees :: Forest ZettelID
trees =
  case Maybe Int
maxLevel of
    Just 0 -> HtmlT m ()
forall a. Monoid a => a
mempty
    _ -> do
      Forest ZettelID -> (Tree ZettelID -> HtmlT m ()) -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Forest ZettelID -> Forest ZettelID
sortForest Forest ZettelID
trees) ((Tree ZettelID -> HtmlT m ()) -> HtmlT m ())
-> (Tree ZettelID -> HtmlT m ()) -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ \(Node zid :: ZettelID
zid subtrees :: Forest ZettelID
subtrees) ->
        HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
li_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
          let zettelDiv :: HtmlT m () -> HtmlT m ()
zettelDiv =
                [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
div_
                  [Text -> Attribute
class_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Bool -> Text
forall a. a -> a -> Bool -> a
bool "" "ui black label" (Bool -> Text) -> Bool -> Text
forall a b. (a -> b) -> a -> b
$ LinkTheme
ltheme LinkTheme -> LinkTheme -> Bool
forall a. Eq a => a -> a -> Bool
== LinkTheme
LinkTheme_Default]
          (HtmlT m () -> HtmlT m ())
-> (HtmlT m () -> HtmlT m ()) -> Bool -> HtmlT m () -> HtmlT m ()
forall a. a -> a -> Bool -> a
bool HtmlT m () -> HtmlT m ()
forall a. a -> a
id HtmlT m () -> HtmlT m ()
zettelDiv Bool
isRoot (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$
            LinkTheme -> ZettelStore -> ZettelID -> HtmlT m ()
forall (m :: * -> *).
Monad m =>
LinkTheme -> ZettelStore -> ZettelID -> HtmlT m ()
renderZettelLink LinkTheme
ltheme ZettelStore
s ZettelID
zid
          Bool -> HtmlT m () -> HtmlT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LinkTheme
ltheme LinkTheme -> LinkTheme -> Bool
forall a. Eq a => a -> a -> Bool
== LinkTheme
LinkTheme_Default) (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
            " "
            case ZettelID -> ZettelGraph -> [ZettelID]
backlinks ZettelID
zid ZettelGraph
g of
              conns :: [ZettelID]
conns@(_ : _ : _) ->
                -- Has two or more backlinks
                [ZettelID] -> (ZettelID -> HtmlT m ()) -> HtmlT m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ZettelID]
conns ((ZettelID -> HtmlT m ()) -> HtmlT m ())
-> (ZettelID -> HtmlT m ()) -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ \zid2 :: ZettelID
zid2 -> do
                  let z2 :: Zettel
z2 = ZettelID -> ZettelStore -> Zettel
lookupStore ZettelID
zid2 ZettelStore
s
                  [Attribute] -> HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
i_ [Text -> Attribute
class_ "fas fa-link", Text -> Attribute
forall arg result. Term arg result => arg -> result
title_ (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ ZettelID -> Text
unZettelID ZettelID
zid2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Zettel -> Text
zettelTitle Zettel
z2] HtmlT m ()
forall a. Monoid a => a
mempty
              _ -> HtmlT m ()
forall a. Monoid a => a
mempty
          Bool -> HtmlT m () -> HtmlT m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Forest ZettelID -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest ZettelID
subtrees Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ do
            HtmlT m () -> HtmlT m ()
forall arg result. Term arg result => arg -> result
ul_ (HtmlT m () -> HtmlT m ()) -> HtmlT m () -> HtmlT m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
forall (m :: * -> *).
Monad m =>
Bool
-> Maybe Int
-> LinkTheme
-> ZettelStore
-> ZettelGraph
-> Forest ZettelID
-> HtmlT m ()
renderForest Bool
False ((\n :: Int
n -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
maxLevel) LinkTheme
ltheme ZettelStore
s ZettelGraph
g Forest ZettelID
subtrees
  where
    -- Sort trees so that trees containing the most recent zettel (by ID) come first.
    sortForest :: Forest ZettelID -> Forest ZettelID
sortForest = Forest ZettelID -> Forest ZettelID
forall a. [a] -> [a]
reverse (Forest ZettelID -> Forest ZettelID)
-> (Forest ZettelID -> Forest ZettelID)
-> Forest ZettelID
-> Forest ZettelID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree ZettelID -> ZettelID) -> Forest ZettelID -> Forest ZettelID
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Tree ZettelID -> ZettelID
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum

style :: Css
style :: Css
style = do
  let linkColor :: Color
linkColor = Color
C.mediumaquamarine
      linkTitleColor :: Color
linkTitleColor = Color
forall a. Auto a => a
C.auto
  "span.zettel-link span.zettel-link-idlink a" Selector -> Css -> Css
? do
    [Text] -> [GenericFontFamily] -> Css
C.fontFamily [] [GenericFontFamily
C.monospace]
    FontWeight -> Css
C.fontWeight FontWeight
C.bold
    Color -> Css
C.color Color
linkColor
    TextDecoration -> Css
C.textDecoration TextDecoration
forall a. None a => a
C.none
  "span.zettel-link span.zettel-link-idlink a:hover" Selector -> Css -> Css
? do
    Color -> Css
C.backgroundColor Color
linkColor
    Color -> Css
C.color Color
C.white
  ".zettel-link .zettel-link-title" Selector -> Css -> Css
? do
    Size LengthUnit -> Css
forall a. Size a -> Css
C.paddingLeft (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.3
    FontWeight -> Css
C.fontWeight FontWeight
C.bold
    Color -> Css
C.color Color
linkTitleColor
  "div.z-index" Selector -> Css -> Css
? do
    Selector
C.ul Selector -> Css -> Css
? do
      ListStyleType -> Css
C.listStyleType ListStyleType
C.square
      Size LengthUnit -> Css
forall a. Size a -> Css
C.paddingLeft (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 1.5
  "div.zettel-view" Selector -> Css -> Css
? do
    Selector
C.ul Selector -> Css -> Css
? do
      Size LengthUnit -> Css
forall a. Size a -> Css
C.paddingLeft (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 1.5
      ListStyleType -> Css
C.listStyleType ListStyleType
C.square
      Selector
C.li Selector -> Css -> Css
? do
        Css
forall a. Monoid a => a
mempty -- C.paddingBottom $ em 1
    Selector
C.h1 Selector -> Css -> Css
? do
      Size LengthUnit -> Css
forall a. Size a -> Css
C.paddingTop (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.2
      Size LengthUnit -> Css
forall a. Size a -> Css
C.paddingBottom (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.2
      TextAlign -> Css
C.textAlign TextAlign
forall a. Center a => a
C.center
      Color -> Css
C.color Color
C.midnightblue
      FontWeight -> Css
C.fontWeight FontWeight
C.bold
      Color -> Css
C.backgroundColor Color
C.whitesmoke
    Selector
C.h2 Selector -> Css -> Css
? do
      Color -> Css
C.fontColor Color
C.darkslategray
      FontWeight -> Css
C.fontWeight FontWeight
C.bold
      Stroke -> Size LengthUnit -> Color -> Css
C.borderBottom Stroke
C.solid (Double -> Size LengthUnit
px 1) Color
C.steelblue
      Size LengthUnit -> Css
forall a. Size a -> Css
C.marginBottom (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.5
    Selector
C.h3 Selector -> Css -> Css
? do
      Color -> Css
C.fontColor Color
C.slategray
      FontWeight -> Css
C.fontWeight FontWeight
C.bold
      Size LengthUnit
-> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css
forall a. Size a -> Size a -> Size a -> Size a -> Css
C.margin (Double -> Size LengthUnit
px 0) (Double -> Size LengthUnit
px 0) (Double -> Size LengthUnit
em 0.4) (Double -> Size LengthUnit
px 0)
    Css
codeStyle
    Css
blockquoteStyle
    Selector
kbd Selector -> Css -> Css
? Css
mozillaKbdStyle
  "div.connections" Selector -> Css -> Css
? do
    "a" Selector -> Css -> Css
? do
      Css -> Css
C.important (Css -> Css) -> Css -> Css
forall a b. (a -> b) -> a -> b
$ Color -> Css
color Color
white
    "a:hover" Selector -> Css -> Css
? do
      Double -> Css
C.opacity 0.5
  ".footer" Selector -> Css -> Css
? do
    "a" Selector -> Css -> Css
? do
      Color -> Css
C.color Color
white
  ".footer-version, .footer-version a, .footer-version a:visited" Selector -> Css -> Css
? do
    Color -> Css
C.color Color
gray
  ".footer-version a" Selector -> Css -> Css
? do
    FontWeight -> Css
C.fontWeight FontWeight
C.bold
  ".footer-version" Selector -> Css -> Css
? do
    Size LengthUnit -> Css
forall a. Size a -> Css
C.fontSize (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.7
  where
    codeStyle :: Css
codeStyle = do
      Selector
C.code Selector -> Css -> Css
? do
        (Size Any -> Size Any -> Size Any -> Size Any -> Css)
-> Size Any -> Css
forall a. (a -> a -> a -> a -> Css) -> a -> Css
sym Size Any -> Size Any -> Size Any -> Size Any -> Css
forall a. Size a -> Size a -> Size a -> Size a -> Css
margin Size Any
forall a. Auto a => a
auto
        Size Percentage -> Css
forall a. Size a -> Css
fontSize (Size Percentage -> Css) -> Size Percentage -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size Percentage
pct 90
      "code, pre, tt" Selector -> Css -> Css
? do
        [Text] -> [GenericFontFamily] -> Css
fontFamily ["SFMono-Regular", "Menlo", "Monaco", "Consolas", "Liberation Mono", "Courier New"] [GenericFontFamily
monospace]
      Selector
pre Selector -> Css -> Css
? do
        (Size LengthUnit
 -> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css)
-> Size LengthUnit -> Css
forall a. (a -> a -> a -> a -> Css) -> a -> Css
sym Size LengthUnit
-> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css
forall a. Size a -> Size a -> Size a -> Size a -> Css
padding (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.5
        Overflow -> Css
C.overflow Overflow
forall a. Auto a => a
auto
        Size Percentage -> Css
forall a. Size a -> Css
C.maxWidth (Size Percentage -> Css) -> Size Percentage -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size Percentage
pct 100
      "div.source-code" Selector -> Css -> Css
? do
        Size Any -> Css
forall a. Size a -> Css
marginLeft Size Any
forall a. Auto a => a
auto
        Size Any -> Css
forall a. Size a -> Css
marginRight Size Any
forall a. Auto a => a
auto
        Size Percentage -> Css
forall a. Size a -> Css
maxWidth (Size Percentage -> Css) -> Size Percentage -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size Percentage
pct 80
        Selector
pre Selector -> Css -> Css
? do
          Color -> Css
backgroundColor "#f8f8f8"
    -- https://css-tricks.com/snippets/css/simple-and-nice-blockquote-styling/
    blockquoteStyle :: Css
blockquoteStyle = do
      Selector
C.blockquote Selector -> Css -> Css
? do
        -- TODO: quotes in clay?
        Color -> Css
C.backgroundColor "#f9f9f9"
        Stroke -> Size LengthUnit -> Color -> Css
C.borderLeft Stroke
C.solid (Double -> Size LengthUnit
px 10) "#ccc"
        (Size LengthUnit
 -> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css)
-> Size LengthUnit -> Size LengthUnit -> Css
forall tb lr. (tb -> lr -> tb -> lr -> Css) -> tb -> lr -> Css
sym2 Size LengthUnit
-> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css
forall a. Size a -> Size a -> Size a -> Size a -> Css
C.margin (Double -> Size LengthUnit
em 1.5) (Double -> Size LengthUnit
px 10)
        (Size LengthUnit
 -> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css)
-> Size LengthUnit -> Size LengthUnit -> Css
forall tb lr. (tb -> lr -> tb -> lr -> Css) -> tb -> lr -> Css
sym2 Size LengthUnit
-> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css
forall a. Size a -> Size a -> Size a -> Size a -> Css
C.padding (Double -> Size LengthUnit
em 0.5) (Double -> Size LengthUnit
px 10)
        Selector
C.p Selector -> Css -> Css
? do
          Display -> Css
C.display Display
C.inline
      "blockquote:before" Selector -> Css -> Css
? do
        Color -> Css
C.color "#ccc"
        Content -> Css
C.content Content
C.openQuote
        Size LengthUnit -> Css
forall a. Size a -> Css
C.fontSize (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 4
        Size LengthUnit -> Css
forall a. Size a -> Css
C.lineHeight (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.1
        Size LengthUnit -> Css
forall a. Size a -> Css
C.marginRight (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em 0.25
        Size LengthUnit -> Css
forall a. VerticalAlign a => a -> Css
C.verticalAlign (Size LengthUnit -> Css) -> Size LengthUnit -> Css
forall a b. (a -> b) -> a -> b
$ Double -> Size LengthUnit
em (Double -> Size LengthUnit) -> Double -> Size LengthUnit
forall a b. (a -> b) -> a -> b
$ -0.4