From fb04af3bf81711f4844de2901dbc1113ba060e81 Mon Sep 17 00:00:00 2001
From: Yann Herklotz <git@yannherklotz.com>
Date: Wed, 10 May 2023 17:02:26 +0100
Subject: Add generation for hugo

---
 src/Zettel/Links.hs  | 158 +++++++++++++++++++++++++++++++++++++++++++++++++++
 src/Zettel/Parse.hs  | 140 +++++++++++++++++++++++++++++++++++++++++++++
 src/Zettel/Render.hs |  47 +++++++++++++++
 src/Zettel/Types.hs  | 106 ++++++++++++++++++++++++++++++++++
 4 files changed, 451 insertions(+)
 create mode 100644 src/Zettel/Links.hs
 create mode 100644 src/Zettel/Parse.hs
 create mode 100644 src/Zettel/Render.hs
 create mode 100644 src/Zettel/Types.hs

(limited to 'src/Zettel')

diff --git a/src/Zettel/Links.hs b/src/Zettel/Links.hs
new file mode 100644
index 0000000..6857d45
--- /dev/null
+++ b/src/Zettel/Links.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Zettel.Links where
+
+import Data.Char (isAlphaNum, isLetter, isNumber)
+import Data.List (nub)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import Data.Text.Read (decimal)
+import Numeric (readInt, showIntAtBase)
+import Text.Pandoc.Builder (HasMeta (..))
+import Text.Pandoc.Definition (Inline (..), Pandoc (..))
+import Text.Pandoc.Shared (stringify)
+import Text.Pandoc.Walk (query, walk)
+import Zettel.Types
+
+parseIds :: Text -> Text
+parseIds t
+  | T.null t = ""
+  | T.head t == '#' && T.all isAlphaNum (T.tail t) = T.tail t
+  | otherwise = ""
+
+splitId :: ZettelId -> [Text]
+splitId (ZettelId zid)
+  | T.null zid = []
+  | isNumber (T.head zid) = T.takeWhile isNumber zid : (splitId . ZettelId $ T.dropWhile isNumber zid)
+  | isLetter (T.head zid) = T.takeWhile isLetter zid : (splitId . ZettelId $ T.dropWhile isLetter zid)
+  | otherwise = []
+
+combineId :: [Text] -> ZettelId
+combineId = ZettelId . fold
+
+intToDigit26 :: Int -> Char
+intToDigit26 i
+  | i <= 25 && i >= 0 = toEnum $ fromEnum 'a' + i
+  | otherwise = error "Integer out of range."
+
+digitToInt26 :: Char -> Int
+digitToInt26 c = fromEnum c - fromEnum 'a'
+
+fromBase :: Int -> String -> Maybe Int
+fromBase base = fmap fst . viaNonEmpty head . readInt base ((< base) . digitToInt26) digitToInt26
+
+toBase :: Int -> Int -> String
+toBase base num = showIntAtBase base intToDigit26 num ""
+
+opOnBase26 :: (Int -> Int) -> Text -> Maybe Text
+opOnBase26 f t =
+  fromString . toBase 26 . f <$> fromBase 26 (toString t)
+
+opOnIdPart :: (Int -> Int) -> Text -> Maybe Text
+opOnIdPart f t
+  | T.null t = Nothing
+  | isNumber $ T.head t =
+      case decimal t of
+        Right (a, _) -> Just . show $ f a
+        _ -> Nothing
+  | isLetter $ T.head t = opOnBase26 f t
+  | otherwise = Nothing
+
+defPredId :: ZettelId -> Maybe ZettelId
+defPredId z =
+  case nonEmpty (splitId z) of
+    Just ne ->
+      if last ne == "a" || last ne == "1"
+        then Just (combineId (init ne))
+        else combineId . (init ne <>) . (: []) <$> opOnIdPart (subtract 1) (last ne)
+    Nothing -> Nothing
+
+defNextId :: ZettelId -> Maybe ZettelId
+defNextId z =
+  case nonEmpty (splitId z) of
+    Just ne ->
+      combineId . (init ne <>) . (: []) <$> opOnIdPart (+ 1) (last ne)
+    Nothing -> Nothing
+
+defBranchId :: ZettelId -> Maybe ZettelId
+defBranchId (ZettelId t)
+  | T.null t = Nothing
+  | isNumber $ T.last t = Just (ZettelId (t <> "a"))
+  | isLetter $ T.last t = Just (ZettelId (t <> "1"))
+  | otherwise = Nothing
+
+gatherForwardIds :: Inline -> [ZettelId]
+gatherForwardIds (Link _ i _) = [ZettelId . parseIds $ stringify i]
+gatherForwardIds _ = []
+
+addIdPresent :: ZettelGraph -> Maybe ZettelId -> [ZettelId]
+addIdPresent zg (Just ident) =
+  [ident | ident `elem` Map.keys (unZettelGraph zg)]
+addIdPresent _ Nothing = []
+
+forwardLinkNode :: ZettelGraph -> ZettelId -> ZettelNode -> ZettelNode
+forwardLinkNode zg ident zn =
+  zn
+    { zettelNodeNext =
+        nub
+          ( query gatherForwardIds (zn.zettelNodeZettel.zettelBody)
+              <> addIdPresent zg (defNextId ident)
+              <> addIdPresent zg (defBranchId ident)
+          )
+    }
+
+forwardLink :: ZettelGraph -> ZettelGraph
+forwardLink zg = ZettelGraph . Map.mapWithKey (forwardLinkNode zg) $ unZettelGraph zg
+
+backwardLinkNode :: ZettelGraph -> ZettelId -> ZettelNode -> ZettelNode
+backwardLinkNode graph ident node = Map.foldlWithKey' f node (unZettelGraph graph)
+  where
+    f :: ZettelNode -> ZettelId -> ZettelNode -> ZettelNode
+    f l ident' zg
+      | ident `elem` zg.zettelNodeNext =
+          l {zettelNodePrev = ident' : l.zettelNodePrev}
+      | otherwise = l
+
+backwardLink :: ZettelGraph -> ZettelGraph
+backwardLink zg = ZettelGraph . Map.mapWithKey (backwardLinkNode zg) $ unZettelGraph zg
+
+updatePandocLinksInline :: Inline -> Inline
+updatePandocLinksInline l@(Link a i (_, t))
+  | not $ T.null ids = Link a i ("/tree/" <> ids, t)
+  | otherwise = l
+  where
+    ids = parseIds $ stringify i
+updatePandocLinksInline i = i
+
+updatePandocLinksPandoc :: Pandoc -> Pandoc
+updatePandocLinksPandoc = walk updatePandocLinksInline
+
+updatePandocLinksAttr :: [ZettelId] -> [ZettelId] -> Pandoc -> Pandoc
+updatePandocLinksAttr back forw =
+  setMeta "backlinks" back
+    . setMeta "forwardlinks" forw
+
+updatePandocLinksZettel :: Zettel -> Zettel
+updatePandocLinksZettel zg =
+  zg {zettelBody = updatePandocLinksPandoc (zettelBody zg)}
+
+updatePandocLinksZettelNode :: ZettelNode -> ZettelNode
+updatePandocLinksZettelNode zg =
+  zg {zettelNodeZettel = updatePandocLinksZettel (zettelNodeZettel zg)}
+
+updatePandocAttrZettel :: [ZettelId] -> [ZettelId] -> Zettel -> Zettel
+updatePandocAttrZettel back forw zg =
+  zg {zettelBody = updatePandocLinksAttr back forw (zettelBody zg)}
+
+updatePandocAttrZettelNode :: ZettelNode -> ZettelNode
+updatePandocAttrZettelNode zg =
+  zg {zettelNodeZettel = updatePandocAttrZettel (zettelNodePrev zg) (zettelNodeNext zg) (zettelNodeZettel zg)}
+
+updatePandocLinks :: ZettelGraph -> ZettelGraph
+updatePandocLinks zg = ZettelGraph $ updatePandocLinksZettelNode <$> unZettelGraph zg
+
+updatePandocAttrL :: ZettelGraph -> ZettelGraph
+updatePandocAttrL zg = ZettelGraph $ updatePandocAttrZettelNode <$> unZettelGraph zg
+
+linkAll :: ZettelGraph -> ZettelGraph
+linkAll = updatePandocAttrL . backwardLink . forwardLink . updatePandocLinks
diff --git a/src/Zettel/Parse.hs b/src/Zettel/Parse.hs
new file mode 100644
index 0000000..d6d8aa9
--- /dev/null
+++ b/src/Zettel/Parse.hs
@@ -0,0 +1,140 @@
+module Zettel.Parse where
+
+import Data.Default (def)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import Text.Pandoc.Builder (toMetaValue)
+import Text.Pandoc.Chunks (Chunk (..), ChunkedDoc (..), splitIntoChunks)
+import Text.Pandoc.Class (runIOorExplode)
+import Text.Pandoc.Definition (Block (..), Inline (..), Meta (..), MetaValue (..), Pandoc (..))
+import Text.Pandoc.Readers (readOrg)
+import Text.Pandoc.Shared (stringify)
+import Text.Pandoc.Walk (query, walk)
+import Zettel.Types
+
+decode :: ByteString -> Text
+decode = decodeUtf8
+
+removeHeadings :: Block -> Block
+removeHeadings Header {} = Plain []
+removeHeadings a = a
+
+removeDiv :: [Block] -> [Block]
+removeDiv = concatMap removeDiv'
+  where
+    removeDiv' (Div _ b') = b'
+    removeDiv' a = [a]
+
+queryHeaderMetaData :: [Block] -> [(Text, MetaValue)]
+queryHeaderMetaData = query headingAttr
+  where
+    headingAttr (Header _ (_, _, l) i) =
+      map (bimap exportDate MetaString) l
+        <> [ ("title", MetaInlines i),
+             ("author", MetaInlines [Str "Yann", Space, Str "Herklotz"])
+           ]
+    headingAttr _ = []
+    exportDate s
+      | 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
+
+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
+
+removeSpan :: [Inline] -> [Inline]
+removeSpan = concatMap removeSpan'
+  where
+    removeSpan' (Span _ _) = []
+    removeSpan' a = [a]
+
+removeMathNL :: Inline -> Inline
+removeMathNL (Math mt t) = Math mt . fold $ T.lines t
+removeMathNL a = a
+
+separateTitleTags :: [Inline] -> ([Inline], [ZettelTag])
+separateTitleTags title =
+  (walk removeSpan $ filter (not . isTagSpan) title, map (ZettelTag . stringify) $ filter isTagSpan title)
+  where
+    isTagSpan (Span (_, l, _) _) = "tag" `elem` l
+    isTagSpan _ = False
+
+parseDate :: Text -> Maybe Text
+parseDate t
+  | T.null t = Just t
+  | T.head t == '[' = viaNonEmpty head . T.words $ T.tail t
+  | otherwise = Just t
+
+parseDateVal :: MetaValue -> Maybe MetaValue
+parseDateVal v = MetaString <$> (metaToString v >>= parseDate)
+
+zettelMetaFromMeta :: [ZettelTag] -> Meta -> ZettelMetadata
+zettelMetaFromMeta t m =
+  ZettelMetadata
+    (lookupString "date" m)
+    (lookupString "modified" m)
+    t
+    []
+
+pandocFromChunk :: Chunk -> Pandoc
+pandocFromChunk c =
+  walk removeMathNL
+    . walk removeDiv
+    . walk removeHeadings
+    . Pandoc
+      (Meta (fromList (("custom_id", MetaString (chunkId c)) : headingMeta)))
+    $ chunkContents c
+  where
+    headingMeta = queryHeaderMetaData $ chunkContents c
+
+zettelFromPandoc :: Pandoc -> (ZettelId, Zettel)
+zettelFromPandoc p@(Pandoc attr _) =
+  (ZettelId ident, Zettel title (zettelMetaFromMeta tags attr) p)
+  where
+    ident = fromMaybe "" $ lookupString "custom_id" attr
+    (title, tags) = maybe ([], []) separateTitleTags $ lookupInlines "title" attr
+
+initNode :: Zettel -> ZettelNode
+initNode zettel = ZettelNode zettel cempty cempty
+
+updatePandocAttr :: Pandoc -> Pandoc
+updatePandocAttr (Pandoc attr b) =
+  Pandoc
+    ( Meta
+        ( Map.insert
+            "tags"
+            tags
+            . Map.update
+              (fmap (MetaInlines . fst . separateTitleTags) . metaToInlines)
+              "title"
+            . Map.update
+              parseDateVal
+              "modified"
+            . Map.update parseDateVal "date"
+            $ unMeta attr
+        )
+    )
+    b
+  where
+    tags =
+      toMetaValue . map unZettelTag $
+        maybe [] (snd . separateTitleTags) $
+          lookupInlines "title" attr
+
+parseZettelKasten :: [FilePath] -> IO ZettelGraph
+parseZettelKasten fl = do
+  fs <- mapM readFileBS fl
+  orgFiles <- mapM (runIOorExplode . readOrg def . decode) fs
+  let splitChunks = map (splitIntoChunks "%i.md" False Nothing 15) orgFiles
+  let pandocList = map (updatePandocAttr . pandocFromChunk) $ concatMap chunkedChunks splitChunks
+  return . ZettelGraph . fromList $ map (second initNode . zettelFromPandoc) pandocList
diff --git a/src/Zettel/Render.hs b/src/Zettel/Render.hs
new file mode 100644
index 0000000..c64a910
--- /dev/null
+++ b/src/Zettel/Render.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+
+module Zettel.Render where
+
+import Data.Default (def)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import Paths_org_zk (getDataFileName)
+import Text.Pandoc.Class (runIOorExplode)
+import Text.Pandoc.Definition (Block (..), Inline (..))
+import Text.Pandoc.Options (WriterOptions (..), multimarkdownExtensions)
+import Text.Pandoc.Templates (WithDefaultPartials (..), compileTemplate)
+import Text.Pandoc.Writers (writeMarkdown)
+import Zettel.Types
+
+zettelIdToLink :: ZettelId -> Inline
+zettelIdToLink ident = Link mempty [Str $ "#" <> unZettelId ident] ("/" <> unZettelId ident, "")
+
+renderZettelLinks :: [ZettelId] -> Block
+renderZettelLinks =
+  BulletList . map (\ident -> [Para [zettelIdToLink ident]])
+
+toInlines :: Text -> [Inline]
+toInlines t = intersperse Space . map Str $ T.words t
+
+renderTitleLinks :: Int -> Text -> [ZettelId] -> [Block]
+renderTitleLinks level title ids =
+  [Header level mempty (toInlines title), renderZettelLinks ids]
+
+renderZettel :: ZettelId -> ZettelNode -> IO Text
+renderZettel _ zettel = do
+  templateFile <- getDataFileName "data/markdown.template"
+  template <- decodeUtf8 <$> readFileBS templateFile
+  Right templ <- runIOorExplode . runWithDefaultPartials $ compileTemplate "" template
+  runIOorExplode $
+    writeMarkdown
+      (def {writerTemplate = Just templ, writerExtensions = multimarkdownExtensions})
+      (zettel.zettelNodeZettel.zettelBody)
+
+renderZettelFile :: FilePath -> ZettelId -> ZettelNode -> IO ()
+renderZettelFile dir ident zettel = do
+  t <- renderZettel ident zettel
+  writeFileText (dir <> "/" <> toString (unZettelId ident <> ".md")) t
+
+renderZettelGraphFile :: FilePath -> ZettelGraph -> IO ()
+renderZettelGraphFile fp zg =
+  forM_ (Map.assocs (unZettelGraph zg)) $ uncurry (renderZettelFile fp)
diff --git a/src/Zettel/Types.hs b/src/Zettel/Types.hs
new file mode 100644
index 0000000..26dee7f
--- /dev/null
+++ b/src/Zettel/Types.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Zettel.Types
+  ( Combine (..),
+    UseCombine (..),
+    ZettelId (..),
+    ZettelCat (..),
+    ZettelTag (..),
+    ZettelMetadata (..),
+    Zettel (..),
+    ZettelNode (..),
+    ZettelGraph (..),
+  )
+where
+
+import Text.Pandoc.Builder (ToMetaValue (..))
+import Text.Pandoc.Definition (Inline (..), Pandoc (..))
+
+class Combine a where
+  cappend :: a -> a -> a
+  cempty :: a
+
+newtype UseCombine a = UC a
+
+instance (Monoid a) => Combine (UseCombine a) where
+  cappend (UC a) (UC b) = UC $ a <> b
+  cempty = UC mempty
+
+deriving via (UseCombine Text) instance Combine Text
+
+deriving via (UseCombine Pandoc) instance Combine Pandoc
+
+deriving via (UseCombine [a]) instance Combine [a]
+
+instance Combine (Maybe a) where
+  cappend Nothing a = a
+  cappend a _ = a
+
+  cempty = Nothing
+
+-- | The ZettelId is just Text, however, it should also be possible to convert
+-- it to a list of the ID split up into it's parts.
+newtype ZettelId = ZettelId {unZettelId :: Text}
+  deriving (Show, Eq, Ord, IsString, ToString, Semigroup, Monoid, ToMetaValue)
+  deriving (Combine) via (UseCombine ZettelId)
+
+newtype ZettelTag = ZettelTag {unZettelTag :: Text}
+  deriving (Show, Eq, Ord, IsString, ToString, Semigroup, Monoid, ToMetaValue)
+  deriving (Combine) via (UseCombine ZettelId)
+
+newtype ZettelCat = ZettelCat {unZettelCat :: Text}
+  deriving (Show, Eq, Ord, IsString, ToString, Semigroup, Monoid, ToMetaValue)
+  deriving (Combine) via (UseCombine ZettelId)
+
+data ZettelMetadata = ZettelMetadata
+  { -- | Optional creation date of the Zettel.
+    zettelCreationDate :: Maybe Text,
+    -- | Optional last modified date of the Zettel.
+    zettelModifiedDate :: Maybe Text,
+    -- | Optional tags.
+    zettelTags :: [ZettelTag],
+    -- | Optional Category
+    zettelCategory :: [ZettelCat]
+  }
+  deriving (Show, Eq)
+
+instance Combine ZettelMetadata where
+  cappend (ZettelMetadata c m t a) (ZettelMetadata c' m' t' a') =
+    ZettelMetadata (cappend c c') (cappend m m') (cappend t t') (cappend a a')
+
+  cempty = ZettelMetadata cempty cempty cempty cempty
+
+data Zettel = Zettel
+  { -- | The title of the Zettel, which should also be present in the body,
+    -- however, this is useful to gather metadata about the Zettel.
+    zettelTitle :: ![Inline],
+    -- | Zettel metadata which is mostly optional.
+    zettelMetadata :: ZettelMetadata,
+    -- | The text body of the Zettel, which is stored as a Pandoc document to
+    -- make it easy to export to other documents.
+    zettelBody :: Pandoc
+  }
+  deriving (Show, Eq)
+
+instance Combine Zettel where
+  cappend (Zettel b c d) (Zettel b' c' d') =
+    Zettel (cappend b b') (cappend c c') (cappend d d')
+
+  cempty = Zettel cempty cempty cempty
+
+data ZettelNode = ZettelNode
+  { zettelNodeZettel :: Zettel,
+    zettelNodeNext :: [ZettelId],
+    zettelNodePrev :: [ZettelId]
+  }
+  deriving (Show, Eq)
+
+instance Combine ZettelNode where
+  cappend (ZettelNode b c d) (ZettelNode b' c' d') =
+    ZettelNode (cappend b b') (cappend c c') (cappend d d')
+
+  cempty = ZettelNode cempty cempty cempty
+
+newtype ZettelGraph = ZettelGraph {unZettelGraph :: Map ZettelId ZettelNode}
-- 
cgit