initHEADtrunk

1 files changed, 201 insertions, 0 deletions

diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..365ae48
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,201 @@
+module Main where
+
+import Hakyll hiding (fromList)
+import Hakyll qualified
+
+import Data.Binary (Binary)
+import Data.String (IsString (fromString))
+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM)
+
+import Data.Map.Lazy qualified as Map
+
+main ∷ IO ()
+main = hakyll $ do
+  match "css/*.css" copyAll
+  match "images/**" copyAll
+
+  match "css/*.hs" do
+    route toCss
+    compile $ getResourceString >>= withItemBody (unixFilter "runghc" [])
+
+  match "src/*.hs" $
+    compile getResourceString
+
+  match "templates/*" $
+    compile templateBodyCompiler
+
+  cards ← buildCards "notes/index.md"
+  let dep = cardsDependency cards
+  let ids = cardId <$> cardsList cards
+  let all = Hakyll.fromList ids
+  rulesExtraDependencies [dep] $ match all do
+    route toHtml
+    compile $ do
+      card ← getUnderlying >>= cardsGet cards
+      nav ← cardNav cards card
+      pandocCompiler
+        <&> fmap (nav <>)
+        >>= loadAndApplyTemplate "templates/card.html" pageCtx
+        >>= loadAndApplyTemplate "templates/default.html" pageCtx
+        >>= relativizeUrls
+
+  match "pages/*.md" $ do
+    route $ gsubRoute "pages/" (const "") `composeRoutes` toHtml
+    let top5 key sortBy = loadAll all >>= sortBy <&> take 5 . reverse
+    let genCtx key = listField key pageCtx . top5 key
+    compile . pageCompiler "templates/default.html" $
+      pageCtx
+        <> genCtx "cardsModified" byModified
+        <> genCtx "cardsPublished" byPublished
+
+pageCtx ∷ Context String
+pageCtx =
+  defaultContext
+    <> snippetField
+    <> dateField "date" dateFormat
+    <> modificationTimeField "dateModified" dateFormat
+
+cardNav ∷ Cards → Card → Compiler String
+cardNav cards self = do
+  let selfId = cardId self
+  let parentId = cardParent self
+
+  children ← navChildren cards "" self
+
+  siblings ←
+    if parentId == cardIdNone
+      then pure ""
+      else cardsGet cards parentId >>= navChildren cards selfId
+
+  aunties ←
+    if parentId == cardIdNone
+      then pure ""
+      else do
+        parent ← cardsGet cards parentId
+        let grandparent = cardParent parent
+        if grandparent == cardIdNone
+          then pure ""
+          else cardsGet cards grandparent >>= navChildren cards parentId
+
+  pure $
+    "<header>\n"
+      <> ("<h1>" <> cardTitle self <> "</h1>\n")
+      <> aunties
+      <> siblings
+      <> children
+      <> "</header>"
+ where
+  wrap s = "<nav><ul>" <> s <> "</ul></nav>\n"
+  navChildren cards cur self =
+    wrap . htmlOf cur <$> routeChildren cards self
+  htmlOf cur routed = mconcat $ htmlOfOne cur <$> routed
+  htmlOfOne cur (card, path) =
+    "<li><a href=\"/"
+      <> path
+      <> "\""
+      <> (if cur == cardId card then "class=\"current\"" else "")
+      <> ">"
+      <> cardTitle card
+      <> "</a></li>\n"
+
+routeChildren ∷ Cards → Card → Compiler [(Card, FilePath)]
+routeChildren cards self = do
+  let children = cardChildren self
+  childrenCards ← cardsGet cards `mapM` children
+  childrenRoutes ← cardDotHtml `mapM` children
+  pure $ zip childrenCards childrenRoutes
+
+{-parent ← cardsGet cards $ cardParent self
+grandparent ← cardsGet cards $ cardParent parent
+
+aunties ← cardsGet cards `mapM` cardChildren grandparent
+siblings ← cardsGet cards `mapM` cardChildren parent-}
+
+buildCards ∷ (MonadFail m, MonadMetadata m) ⇒ CardId → m Cards
+buildCards id = do
+  cardMap ← buildCardMap cardIdNone id
+  dependencies ← makePatternDependency "notes/*.md"
+  pure (cardMap, dependencies)
+
+buildCardMap ∷ (MonadFail m, MonadMetadata m) ⇒ CardId → CardId → m CardMap
+buildCardMap parent id = do
+  meta ← getMetadata id
+  title ← getMetadataField' id "title"
+  let children = cardFromSymbol <$> fromMaybe [] (lookupStringList "children" meta)
+  let card = Card id parent children title
+  (<>) [(id, card)] . Map.unions <$> forM children (buildCardMap id)
+
+cardFromSymbol ∷ ToString α ⇒ α → CardId
+cardFromSymbol = fromString . (<> ".md") . ("notes/" <>) . toString
+
+cardDotHtml ∷ CardId → Compiler FilePath
+cardDotHtml id =
+  getRoute id >>= \case
+    Just x → pure x
+    Nothing → fail "Card must have a route"
+
+dateFormat ∷ String
+dateFormat = "%e %b %Y %H:%M:%S"
+
+pageCompiler ∷ Identifier → Context String → Compiler (Item String)
+pageCompiler template ctx =
+  getResourceString
+    >>= applyAsTemplate ctx
+    >>= renderPandoc
+    >>= loadAndApplyTemplate template ctx
+    >>= relativizeUrls
+
+copyAll ∷ Rules ()
+copyAll = route idRoute >> compile copyFileCompiler
+
+toHtml, toCss ∷ Routes
+toHtml = setExtension "html"
+toCss = setExtension "css"
+
+byModified, byPublished ∷ [Item a] → Compiler [Item a]
+byModified = sortByM modified
+byPublished = sortByM published
+
+modified, published ∷ Item a → Compiler UTCTime
+modified = getItemModificationTime . itemIdentifier
+published = getItemUTC defaultTimeLocale . itemIdentifier
+
+getDateField ∷ (MonadMetadata m, MonadFail m) ⇒ String → Item a → m UTCTime
+getDateField key x = do
+  field ← getMetadataField (itemIdentifier x) key
+  case field of
+    Just str →
+      parseTimeM True defaultTimeLocale dateFormat str
+    Nothing →
+      fail $ "Couldn't get field " ++ key ++ " for " ++ show (itemIdentifier x)
+
+cardIdNone ∷ CardId
+cardIdNone = ""
+
+type CardId = Identifier
+
+data Card = Card
+  { cardId ∷ CardId
+  , cardParent ∷ CardId
+  , cardChildren ∷ [CardId]
+  , cardTitle ∷ String
+  }
+
+cardsMap ∷ Cards → CardMap
+cardsDependency ∷ Cards → Dependency
+cardsList ∷ Cards → [Card]
+cardsGet ∷ Cards → CardId → Compiler Card
+
+cardsDependency (_, d) = d
+cardsMap (m, _) = m
+cardsList = Map.elems . cardsMap
+cardsGet cards id =
+  case cardsMap cards Map.!? id of
+    Just card → pure card
+    Nothing → fail "???"
+
+type Cards = (CardMap, Dependency)
+type CardMap = Map CardId Card
+
+sortByM ∷ (Monad m, Ord k) ⇒ (a → m k) → [a] → m [a]
+sortByM f xs = map fst . sortBy (comparing snd) <$> mapM (liftA2 fmap (,) f) xs