From 69a6187804aff44f48fe9047895e8c027ad5bf3f Mon Sep 17 00:00:00 2001 From: kitty piapiac Date: Thu, 3 Oct 2024 06:13:41 +0100 Subject: init --- src/Main.hs | 201 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 201 insertions(+) create mode 100644 src/Main.hs (limited to 'src') 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 $ + "
\n" + <> ("

" <> cardTitle self <> "

\n") + <> aunties + <> siblings + <> children + <> "
" + where + wrap s = "\n" + navChildren cards cur self = + wrap . htmlOf cur <$> routeChildren cards self + htmlOf cur routed = mconcat $ htmlOfOne cur <$> routed + htmlOfOne cur (card, path) = + "
  • path + <> "\"" + <> (if cur == cardId card then "class=\"current\"" else "") + <> ">" + <> cardTitle card + <> "
    • \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 -- cgit v1.2.3