blob: 6bc7b2bebca0c0bf2f419c504a6e65dbccca5ad8 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
{-# LANGUAGE OverloadedRecordDot #-}
-- |
-- Module : Zettel.Transclusion
-- Description : Transclude Zettel recursively
-- Copyright : (c) 2023, Yann Herklotz
-- License : GPL-3
-- Maintainer : git [at] yannherklotz [dot] com
-- Stability : experimental
-- Portability : POSIX
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 (query, walk)
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
|
