From 02d36d9c5c55d49bdfedf29fb9aff9202f19cf53 Mon Sep 17 00:00:00 2001 From: Yann Herklotz Date: Sun, 28 May 2023 03:52:10 +0100 Subject: Add support for bibliography notes export --- org-zk.cabal | 1 + src/Main.hs | 10 ++++----- src/Zettel.hs | 2 ++ src/Zettel/Bibliography.hs | 25 ++++++++++++++++++++++ src/Zettel/Common.hs | 23 +++++++++++++++++++- src/Zettel/Parse.hs | 52 +++++++++++++++++++++------------------------- src/Zettel/Render.hs | 19 ++++++++++++++--- src/Zettel/Types.hs | 13 ++++++++---- 8 files changed, 103 insertions(+), 42 deletions(-) create mode 100644 src/Zettel/Bibliography.hs diff --git a/org-zk.cabal b/org-zk.cabal index bca2ac2..5170bd1 100644 --- a/org-zk.cabal +++ b/org-zk.cabal @@ -50,6 +50,7 @@ executable org-zk main-is: Main.hs other-modules: Zettel + , Zettel.Bibliography , Zettel.Common , Zettel.Links , Zettel.Math diff --git a/src/Main.hs b/src/Main.hs index 002fbff..c819300 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -262,7 +262,7 @@ options = Option [] ["org-bibliography"] - (ReqArg (\f opts -> opts {optBibliography = Just f}) "FILE") + (ReqArg (\f opts -> opts {optOrgBibliography = Just f}) "FILE") "Bibliography FILE (default: bibliography.org)", Option ['q'] @@ -305,11 +305,9 @@ main = do putStrLn version exitSuccess - graph' <- parseZettelKasten $ zip [1 ..] fl + graph <- parseZettelKasten (zip [1 ..] fl) (optOrgBibliography zkOpts) - let graph = transcludeMdAll graph' - let linkedGraph = linkAll graph - let wrappedGraph = wrapZettelGraph linkedGraph + let pipeline = transcludeMdAll >> linkAll >> wrapZettelGraph >> handleBibliography renderZettelGraphFile (optVerbose zkOpts) @@ -319,4 +317,4 @@ main = do ) (optBibliography zkOpts) (fromMaybe "output" (optOutput zkOpts)) - wrappedGraph + (pipeline graph) diff --git a/src/Zettel.hs b/src/Zettel.hs index 63b4910..7c85ae6 100644 --- a/src/Zettel.hs +++ b/src/Zettel.hs @@ -5,9 +5,11 @@ module Zettel module Zettel.Parse, module Zettel.Transclusion, module Zettel.Math, + module Zettel.Bibliography, ) where +import Zettel.Bibliography import Zettel.Links import Zettel.Math import Zettel.Parse diff --git a/src/Zettel/Bibliography.hs b/src/Zettel/Bibliography.hs new file mode 100644 index 0000000..6186917 --- /dev/null +++ b/src/Zettel/Bibliography.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module Zettel.Bibliography where + +import Text.Pandoc.Definition (Citation (..), Inline (..), Target (..)) +import Text.Pandoc.Walk (walk) +import Zettel.Types + +replaceCitation :: Citation -> ([Inline], Target) +replaceCitation c = + ([Str $ "@" <> zid], ("/bib/" <> zid, "")) + where + zid = citationId c + +replaceCite :: Inline -> [Inline] +replaceCite (Cite c _) = + [Str "("] <> map (uncurry (Link mempty) . replaceCitation) c <> [Str ")"] +replaceCite c = [c] + +replaceCites :: [Inline] -> [Inline] +replaceCites = concatMap replaceCite + +handleBibliography :: ZettelGraph -> ZettelGraph +handleBibliography zg = + if null zg.zettelGraphBib then zg else zg {unZettelGraph = walk replaceCites zg.unZettelGraph} diff --git a/src/Zettel/Common.hs b/src/Zettel/Common.hs index 7b77417..515ebd5 100644 --- a/src/Zettel/Common.hs +++ b/src/Zettel/Common.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import Data.Text.Read (decimal) import Numeric (readInt, showIntAtBase) import Text.Pandoc.Builder (HasMeta (..), ToMetaValue (..)) -import Text.Pandoc.Definition (MetaValue (..), Pandoc (..)) +import Text.Pandoc.Definition (Inline (..), Meta (..), MetaValue (..), Pandoc (..)) import Zettel.Types trySet :: (HasMeta a, ToMetaValue b) => Text -> Maybe b -> a -> a @@ -111,3 +111,24 @@ parseLink :: Text -> ZettelId parseLink t = ZettelId $ parseIds ident where ident = T.takeWhile (']' /=) $ T.dropWhile ('#' /=) t + +metaToString :: MetaValue -> Maybe Text +metaToString (MetaString t) = Just t +metaToString _ = Nothing + +metaToInlines :: MetaValue -> Maybe [Inline] +metaToInlines (MetaInlines t) = Just t +metaToInlines _ = Nothing + +metaToTextList :: MetaValue -> Maybe [Text] +metaToTextList (MetaList t) = traverse metaToString t +metaToTextList _ = Nothing + +lookupString :: Text -> Meta -> Maybe Text +lookupString t m = Map.lookup t (unMeta m) >>= metaToString + +lookupInlines :: Text -> Meta -> Maybe [Inline] +lookupInlines t m = Map.lookup t (unMeta m) >>= metaToInlines + +lookupTextList :: Text -> Meta -> Maybe [Text] +lookupTextList t m = Map.lookup t (unMeta m) >>= metaToTextList diff --git a/src/Zettel/Parse.hs b/src/Zettel/Parse.hs index bb08291..943e343 100644 --- a/src/Zettel/Parse.hs +++ b/src/Zettel/Parse.hs @@ -41,27 +41,6 @@ queryHeaderMetaData = query headingAttr | s == "export_date" = "date" | otherwise = s -metaToString :: MetaValue -> Maybe Text -metaToString (MetaString t) = Just t -metaToString _ = Nothing - -metaToInlines :: MetaValue -> Maybe [Inline] -metaToInlines (MetaInlines t) = Just t -metaToInlines _ = Nothing - -metaToTextList :: MetaValue -> Maybe [Text] -metaToTextList (MetaList t) = traverse metaToString t -metaToTextList _ = Nothing - -lookupString :: Text -> Meta -> Maybe Text -lookupString t m = Map.lookup t (unMeta m) >>= metaToString - -lookupInlines :: Text -> Meta -> Maybe [Inline] -lookupInlines t m = Map.lookup t (unMeta m) >>= metaToInlines - -lookupTextList :: Text -> Meta -> Maybe [Text] -lookupTextList t m = Map.lookup t (unMeta m) >>= metaToTextList - removeSpan :: [Inline] -> [Inline] removeSpan = concatMap removeSpan' where @@ -124,6 +103,9 @@ zettelFromPandoc p@(Pandoc attr _) = tags = maybe [] (map ZettelTag) $ lookupTextList "tags" attr cats = maybe [] (map ZettelCat) $ lookupTextList "categories" attr +bibFromPandoc :: Pandoc -> (BibId, Zettel) +bibFromPandoc p = first (\(ZettelId i) -> BibId i) $ zettelFromPandoc p + updatePandocAttr :: Pandoc -> Pandoc updatePandocAttr (Pandoc attr b) = Pandoc @@ -150,14 +132,28 @@ propagateNames :: [((Int, Text), [Chunk])] -> [(Int, Text, Chunk)] propagateNames n = [(i, name, chunk) | ((i, name), namedChunk) <- n, chunk <- namedChunk] -parseZettelKasten :: [(Int, FilePath)] -> IO ZettelGraph -parseZettelKasten fl = do +readFileUtf8 :: FilePath -> IO Text +readFileUtf8 = fmap decode . readFileBS + +readOrgFile :: Text -> IO Pandoc +readOrgFile = runIOorExplode . readOrg (def {readerExtensions = getDefaultExtensions "org"}) + +parseBibliography :: FilePath -> IO [Pandoc] +parseBibliography fp = do + pandoc <- readFileUtf8 fp >>= readOrgFile + let splitChunks = chunkedChunks $ splitIntoChunks "%i.md" False Nothing 1 pandoc + return $ map (updatePandocAttr . pandocFromChunk . (\c -> (8, "bibliography", c))) splitChunks + +parseZettelKasten :: [(Int, FilePath)] -> Maybe FilePath -> IO ZettelGraph +parseZettelKasten fl bibPath = do let names = map (second (T.pack . takeBaseName)) fl - fs <- mapM (readFileBS . snd) fl - orgFiles <- mapM (runIOorExplode . readOrg (def {readerExtensions = getDefaultExtensions "org"}) . decode) fs + fs <- mapM (readFileUtf8 . snd) fl + orgFiles <- mapM readOrgFile fs let splitChunks = map (splitIntoChunks "%i.md" False Nothing 15) orgFiles let chunks = propagateNames . zip names $ map chunkedChunks splitChunks let pandocList = map (updatePandocAttr . pandocFromChunk) chunks - return . refreshPandocMeta $ ZettelGraph (fromList $ map zettelFromPandoc pandocList) Nothing - --- parseBibliography :: FilePath -> IO [Pandoc] + bibliography <- maybe mempty parseBibliography bibPath + return . refreshPandocMeta $ + ZettelGraph + (fromList $ map zettelFromPandoc pandocList) + (fromList $ map bibFromPandoc bibliography) diff --git a/src/Zettel/Render.hs b/src/Zettel/Render.hs index 2451163..662742d 100644 --- a/src/Zettel/Render.hs +++ b/src/Zettel/Render.hs @@ -10,7 +10,7 @@ import System.FilePath ((<.>), ()) import Text.Pandoc.App (applyFilters) import Text.Pandoc.Builder (HasMeta (..)) import Text.Pandoc.Class (runIOorExplode) -import Text.Pandoc.Definition (Block (..), Inline (..)) +import Text.Pandoc.Definition (Block (..), Inline (..), Meta (..), MetaValue (..), Pandoc (..)) import Text.Pandoc.Extensions (Extension (..), disableExtension) import Text.Pandoc.Filter (Environment (..), Filter (..)) import Text.Pandoc.Options (ReaderOptions (..), WriterOptions (..), getDefaultExtensions, multimarkdownExtensions) @@ -91,8 +91,21 @@ renderZettelFile v csl bib dir ident zettel = do t <- renderZettel csl bib ident zettel writeFileText path t where - path = dir toString (unZettelId ident) <.> "md" + path = dir "zettel" toString (unZettelId ident) <.> "md" + +renderBibFile :: Bool -> FilePath -> Maybe FilePath -> FilePath -> BibId -> Zettel -> IO () +renderBibFile v csl bib dir (BibId ident) zettel = do + when v . putStrLn $ "Writing " <> path + t <- renderZettel csl bib (ZettelId ident) zettel + writeFileText path t + where + path = dir "bib" toString ident <.> "md" renderZettelGraphFile :: Bool -> FilePath -> Maybe FilePath -> FilePath -> ZettelGraph -> IO () renderZettelGraphFile v csl bib fp zg = - forM_ (Map.assocs (unZettelGraph zg)) $ uncurry (renderZettelFile v csl bib fp) + forM_ + (Map.assocs (unZettelGraph zg)) + (uncurry (renderZettelFile v csl bib fp)) + >> forM_ + (Map.assocs (zettelGraphBib zg)) + (uncurry (renderBibFile v csl bib fp)) diff --git a/src/Zettel/Types.hs b/src/Zettel/Types.hs index 1e8f750..791bc9c 100644 --- a/src/Zettel/Types.hs +++ b/src/Zettel/Types.hs @@ -14,6 +14,7 @@ module Zettel.Types ZettelMetadata (..), Zettel (..), ZettelGraph (..), + BibId (..), ) where @@ -49,6 +50,10 @@ newtype ZettelId = ZettelId {unZettelId :: Text} deriving (Show, Eq, Ord, IsString, ToString, Semigroup, Monoid, ToMetaValue) deriving (Combine) via (UseCombine ZettelId) +newtype BibId = BibId {unBibId :: Text} + deriving (Show, Eq, Ord, IsString, ToString, Semigroup, Monoid, ToMetaValue) + deriving (Combine) via (UseCombine BibId) + newtype ZettelTag = ZettelTag {unZettelTag :: Text} deriving (Show, Eq, Ord, IsString, ToString, Semigroup, Monoid, ToMetaValue) deriving (Combine) via (UseCombine ZettelId) @@ -140,7 +145,7 @@ instance Walkable [Inline] Zettel where data ZettelGraph = ZettelGraph { unZettelGraph :: Map ZettelId Zettel, - zettelGraphBib :: Maybe Pandoc + zettelGraphBib :: Map BibId Zettel } deriving (Show, Eq) @@ -150,8 +155,8 @@ walkMZettelGraph :: ZettelGraph -> m ZettelGraph walkMZettelGraph f b = do - res <- traverse (walkM f) (unZettelGraph b) - newBib <- traverse (walkM f) (zettelGraphBib b) + res <- walkM f (unZettelGraph b) + newBib <- walkM f (zettelGraphBib b) return $ ZettelGraph res newBib queryZettelGraph :: @@ -159,7 +164,7 @@ queryZettelGraph :: (a2 -> a1) -> ZettelGraph -> a1 -queryZettelGraph f g = query f (unZettelGraph g) <> maybe mempty (query f) (zettelGraphBib g) +queryZettelGraph f g = query f (unZettelGraph g) <> query f (zettelGraphBib g) instance Walkable Block ZettelGraph where walkM = walkMZettelGraph -- cgit