Support :level in transclusion

1 files changed, 32 insertions, 11 deletions

diff --git a/src/Zettel/Transclusion.hs b/src/Zettel/Transclusion.hs
index 86a905b..617a475 100644
--- a/src/Zettel/Transclusion.hs
+++ b/src/Zettel/Transclusion.hs
@@ -5,28 +5,47 @@ 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)
+import Text.Pandoc.Walk (walk, query)
 import Zettel.Common
 import Zettel.Types
 
-parseTranscludeBlock :: Text -> ZettelId
-parseTranscludeBlock t = parseLink link
+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 -> [Block]) -> Block -> [Block]
+transcludeRawBlockWith' :: (ZettelId -> Maybe Int -> [Block]) -> Block -> [Block]
 transcludeRawBlockWith' f r@(RawBlock t c)
-  | t == "org" = f $ parseTranscludeBlock c
+  | t == "org" = uncurry f . parseTranscludeBlock $ c
   | otherwise = [r]
 transcludeRawBlockWith' _ p = [p]
 
-transcludeRawBlockWith :: (ZettelId -> [Block]) -> [Block] -> [Block]
+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 $ parseTranscludeBlock c
+      RawBlock "org-zk-transclude" . unZettelId . fst $ parseTranscludeBlock c
   | otherwise = r
 transcludeRawBlock p = p
 
@@ -36,7 +55,7 @@ markdownIdFormat (ZettelId d) =
 
 transcludeToMarkdownLink :: Block -> Block
 transcludeToMarkdownLink r@(RawBlock t c)
-  | t == "org" = Para [Str . markdownIdFormat $ parseTranscludeBlock c]
+  | t == "org" = Para [Str . markdownIdFormat . fst $ parseTranscludeBlock c]
   | otherwise = r
 transcludeToMarkdownLink p = p
 
@@ -53,16 +72,18 @@ wrapTransclude depth zid b =
     <> [Para [RawInline "markdown" $ "{{< /transclude-" <> show depth <> " >}}"]]
 
 transcludeMd :: ZettelGraph -> Int -> Pandoc -> Pandoc
-transcludeMd zg depth = walk (transcludeRawBlockWith f)
+transcludeMd zg depth p = walk (transcludeRawBlockWith f) p
   where
-    f ident =
+    f ident level =
       concatMap
-        ( (\(Pandoc _ b) -> wrapTransclude depth ident b)
+        ( (\(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 =