1 files changed, 158 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