summaryrefslogtreecommitdiffstats
path: root/src/Zettel
diff options
context:
space:
mode:
Diffstat (limited to 'src/Zettel')
-rw-r--r--src/Zettel/Links.hs158
-rw-r--r--src/Zettel/Parse.hs140
-rw-r--r--src/Zettel/Render.hs47
-rw-r--r--src/Zettel/Types.hs106
4 files changed, 451 insertions, 0 deletions
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}
generated by cgit (git 2.34.1) at 2024-06-26 02:46:17 +0000