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