{-# LANGUAGE OverloadedRecordDot #-}

module Zettel.Transclusion where

import Data.Map.Strict ((!?))
import qualified Data.Text as T
import Text.Pandoc.Definition (Block (..), Inline (..), Pandoc (..))
import Text.Pandoc.Walk (walk, query)
import Zettel.Common
import Zettel.Types

between :: Char -> Char -> Text -> Text
between c1 c2 t =
  T.drop 1 . T.takeWhile (c2 /=) $ T.dropWhile (c1 /=) t

attrValue :: Text -> Text -> Maybe Text
attrValue t v = viaNonEmpty head . drop 1 . dropWhile (/= v) $ T.words t

parseTranscludeBlock :: Text -> (ZettelId, Maybe Int)
parseTranscludeBlock t = (parseLink link, level)
  where
    link = T.takeWhile (']' /=) $ T.dropWhile ('[' /=) t
    levelStr = attrValue t ":level"
    level = levelStr >>= readMaybe . T.unpack

transcludeRawBlockWith' :: (ZettelId -> Maybe Int -> [Block]) -> Block -> [Block]
transcludeRawBlockWith' f r@(RawBlock t c)
  | t == "org" = uncurry f . parseTranscludeBlock $ c
  | otherwise = [r]
transcludeRawBlockWith' _ p = [p]

newtype Min = Min Int

instance Semigroup Min where
  Min a <> Min b = Min $ min a b

instance Monoid Min where
  mempty = Min maxInt

findTranscludeFloor :: Block -> Min
findTranscludeFloor (RawBlock t c)
  | t == "org" = maybe mempty Min . snd . parseTranscludeBlock $ c
  | otherwise = mempty
findTranscludeFloor _ = mempty

transcludeRawBlockWith :: (ZettelId -> Maybe Int -> [Block]) -> [Block] -> [Block]
transcludeRawBlockWith f = concatMap (transcludeRawBlockWith' f)

transcludeRawBlock :: Block -> Block
transcludeRawBlock r@(RawBlock t c)
  | t == "org" =
      RawBlock "org-zk-transclude" . unZettelId . fst $ parseTranscludeBlock c
  | otherwise = r
transcludeRawBlock p = p

markdownIdFormat :: ZettelId -> Text
markdownIdFormat (ZettelId d) =
  "{{< transclude zettel=\"" <> d <> "\" >}}"

transcludeToMarkdownLink :: Block -> Block
transcludeToMarkdownLink r@(RawBlock t c)
  | t == "org" = Para [Str . markdownIdFormat . fst $ parseTranscludeBlock c]
  | otherwise = r
transcludeToMarkdownLink p = p

transclude :: Pandoc -> Pandoc
transclude = walk transcludeRawBlock

transcludeMdLink :: Pandoc -> Pandoc
transcludeMdLink = walk transcludeToMarkdownLink

wrapTransclude :: Int -> ZettelId -> [Block] -> [Block]
wrapTransclude depth zid b =
  [Para [RawInline "markdown" $ "{{< transclude-" <> show depth <> " zettel=\"" <> unZettelId zid <> "\" >}}"]]
    <> b
    <> [Para [RawInline "markdown" $ "{{< /transclude-" <> show depth <> " >}}"]]

transcludeMd :: ZettelGraph -> Int -> Pandoc -> Pandoc
transcludeMd zg depth p = walk (transcludeRawBlockWith f) p
  where
    f ident level =
      concatMap
        ( (\(Pandoc _ b) ->
             wrapTransclude (maybe depth (subtract $ floorLvl - 1) level) ident b)
            . transcludeMd zg (depth + 1)
            . zettelBody
        )
        . toList
        $ zg.unZettelGraph !? ident
    Min floorLvl = query findTranscludeFloor p

transcludeMdZettel :: ZettelGraph -> Zettel -> Zettel
transcludeMdZettel zg zettel =
  zettel {zettelBody = transcludeMd zg 1 zettel.zettelBody}

transcludeMdAll :: ZettelGraph -> ZettelGraph
transcludeMdAll zg =
  ZettelGraph (transcludeMdZettel zg <$> unZettelGraph zg) $ zettelGraphBib zg