commonmark-wikilink (empty) → 0.1.0.0

raw patch · 4 files changed

+398/−0 lines, 4 filesdep +aesondep +basedep +commonmark

Dependencies added: aeson, base, commonmark, commonmark-pandoc, megaparsec, network-uri, pandoc-types, parsec, relude, uri-encode, url-slug

Files

• LICENSE +21/−0
• README.md +5/−0
• commonmark-wikilink.cabal +86/−0
• src/Commonmark/Extensions/WikiLink.hs +286/−0

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Sridhar Ratnakumar++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,5 @@+# commonmark-wikilink++An improved version of [the official wikilink extension](https://hackage.haskell.org/package/commonmark-extensions-0.2.3.3/docs/Commonmark-Extensions-Wikilinks.html) that works with Markdown wikilinks in the wild (such as Obsidian).++This library is used in [Emanote](https://emanote.srid.ca/).

@@ -0,0 +1,86 @@+cabal-version:      2.4+name:               commonmark-wikilink+version:            0.1.0.0+license:            MIT+copyright:          2022 Sridhar Ratnakumar+maintainer:         srid@srid.ca+author:             Sridhar Ratnakumar+category:           Web+synopsis:           Obsidian-friendly commonmark wikilink parser+description:        Obsidian-friendly commonmark wikilink parser+bug-reports:        https://github.com/srid/commonmark-wikilink+extra-source-files:+  LICENSE+  README.md++common shared+  ghc-options:+    -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns+    -Wmissing-deriving-strategies -Wunused-foralls -Wunused-foralls+    -fprint-explicit-foralls -fprint-explicit-kinds++  mixins:+    base hiding (Prelude),+    relude (Relude as Prelude, Relude.Container.One),+    relude++  default-extensions:+    NoStarIsType+    BangPatterns+    ConstraintKinds+    DataKinds+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    EmptyCase+    EmptyDataDecls+    EmptyDataDeriving+    ExistentialQuantification+    ExplicitForAll+    FlexibleContexts+    FlexibleInstances+    GADTSyntax+    GeneralisedNewtypeDeriving+    ImportQualifiedPost+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    NumericUnderscores+    OverloadedStrings+    PolyKinds+    PostfixOperators+    RankNTypes+    ScopedTypeVariables+    StandaloneDeriving+    StandaloneKindSignatures+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    ViewPatterns++  build-depends:+    , aeson+    , base               >=4.13.0.0 && <4.18.0.0.0+    , commonmark+    , commonmark-pandoc+    , megaparsec+    , network-uri+    , pandoc-types+    , parsec+    , relude             >=1.0+    , uri-encode+    , url-slug++  hs-source-dirs:     src+  default-language:   Haskell2010++library+  import:          shared+  exposed-modules: Commonmark.Extensions.WikiLink

@@ -0,0 +1,286 @@+{-# LANGUAGE DeriveAnyClass #-}++module Commonmark.Extensions.WikiLink (+  -- * Types+  WikiLink,+  WikiLinkType (..),++  -- * Parsing wikilinks+  mkWikiLinkFromSlugs,+  mkWikiLinkFromInline,+  delineateLink,++  -- * Wikilink candidates+  allowedWikiLinks,++  -- * Converting wikilinks+  wikilinkInline,+  wikiLinkInlineRendered,++  -- * Commonmark parser spec+  wikilinkSpec,++  -- * Anchors in URLs+  Anchor,+  anchorSuffix,++  -- * Pandoc helper+  plainify,+) where++import Commonmark qualified as CM+import Commonmark.Pandoc qualified as CP+import Commonmark.TokParsers qualified as CT+import Control.Monad (liftM2)+import Data.Aeson (ToJSON (toJSON))+import Data.Data (Data)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Text qualified as T+import Network.URI.Encode qualified as UE+import Network.URI.Slug (Slug)+import Network.URI.Slug qualified as Slug+import Text.Megaparsec qualified as M+import Text.Pandoc.Builder qualified as B+import Text.Pandoc.Walk qualified as W+import Text.Parsec qualified as P+import Text.Read (Read (readsPrec))+import Text.Show qualified (Show (show))++{- | Represents the "Foo" in [[Foo]]++ As wiki links may contain multiple path components, it can represent+ [[Foo/Bar]], hence we use nonempty slug list.+-}+newtype WikiLink = WikiLink {unWikiLink :: NonEmpty Slug}+  deriving stock (Eq, Ord, Typeable, Data)++instance ToJSON WikiLink where+  toJSON = toJSON . wikilinkUrl++instance Show WikiLink where+  show wl =+    toString $ "[[" <> wikilinkUrl wl <> "]]"++-- -----------------+-- Making wiki links+-- -----------------++mkWikiLinkFromSlugs :: NonEmpty Slug -> WikiLink+mkWikiLinkFromSlugs = WikiLink++mkWikiLinkFromUrl :: (Monad m, Alternative m) => Text -> m WikiLink+mkWikiLinkFromUrl s = do+  slugs <- maybe empty pure $ nonEmpty $ Slug.decodeSlug <$> T.splitOn "/" s+  pure $ WikiLink slugs++mkWikiLinkFromInline :: B.Inline -> Maybe (WikiLink, [B.Inline])+mkWikiLinkFromInline inl = do+  B.Link (_id, _class, otherAttrs) is (url, tit) <- pure inl+  (Left (_, wl), _manchor) <- delineateLink (otherAttrs <> one ("title", tit)) url+  pure (wl, is)++-- | An URL anchor without the '#'+newtype Anchor = Anchor Text+  deriving newtype (Eq, Show, Ord)++mkAnchor :: String -> Maybe Anchor+mkAnchor ('#' : name) = pure $ Anchor $ toText name+mkAnchor _ = Nothing++anchorSuffix :: Maybe Anchor -> Text+anchorSuffix = maybe "" (\(Anchor a) -> "#" <> a)++dropUrlAnchor :: Text -> (Text, Maybe Anchor)+dropUrlAnchor = second (mkAnchor . toString) . T.breakOn "#"++{- | Given a Pandoc Link node, apparaise what kind of link it is.++ * Nothing, if the link is an absolute URL+ * Just (Left wl), if a wiki-link+ * Just (Right fp), if a relative path (not a wiki-link)+-}+delineateLink :: [(Text, Text)] -> Text -> Maybe (Either (WikiLinkType, WikiLink) FilePath, Maybe Anchor)+delineateLink (Map.fromList -> attrs) url = do+  -- Must be relative+  guard $ not $ "://" `T.isInfixOf` url+  wikiLink <|> internalLink+  where+    wikiLink = do+      wlType :: WikiLinkType <- readMaybe . toString <=< Map.lookup htmlAttr $ attrs+      -- Ignore anchors until https://github.com/srid/emanote/discussions/105+      let (s, manc) = dropUrlAnchor url+      wl <- mkWikiLinkFromUrl s+      pure (Left (wlType, wl), manc)+    internalLink = do+      -- Avoid links like "mailto:", "magnet:", etc.+      -- An easy way to parse them is to look for colon character.+      --+      -- This does mean that "Foo: Bar.md" cannot be linked to this way, however+      -- the user can do it using wiki-links.+      guard $ not $ ":" `T.isInfixOf` url+      let (s, manc) = dropUrlAnchor url+      guard $ not $ T.null s -- Same page anchors+      pure (Right $ UE.decode (toString s), manc)++-- ---------------------+-- Converting wiki links+-- ---------------------++-- | [[Foo/Bar]] -> "Foo/Bar"+wikilinkUrl :: WikiLink -> Text+wikilinkUrl =+  T.intercalate "/" . fmap Slug.unSlug . toList . unWikiLink++wikilinkInline :: WikiLinkType -> WikiLink -> B.Inlines -> B.Inlines+wikilinkInline typ wl = B.linkWith attrs (wikilinkUrl wl) ""+  where+    attrs = ("", [], [(htmlAttr, show typ)])++wikiLinkInlineRendered :: B.Inline -> Maybe Text+wikiLinkInlineRendered x = do+  (wl, inl) <- mkWikiLinkFromInline x+  pure $ case nonEmpty inl of+    Nothing -> show wl+    Just _ ->+      let inlStr = plainify inl+       in if inlStr == wikilinkUrl wl+            then show wl+            else "[[" <> wikilinkUrl wl <> "|" <> plainify inl <> "]]"++{- | Return the various ways to link to a route (ignoring ext)++ Foo/Bar/Qux.md -> [[Qux]], [[Bar/Qux]], [[Foo/Bar/Qux]]++ All possible combinations of Wikilink type use is automatically included.+-}+allowedWikiLinks :: HasCallStack => NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink)+allowedWikiLinks slugs =+  let wls = WikiLink <$> tailsNE slugs+      typs :: NonEmpty WikiLinkType = NE.fromList universe+   in liftM2 (,) typs wls+  where+    tailsNE =+      NE.fromList . mapMaybe nonEmpty . tails . toList++-------------------------+-- Parser+--------------------------++{- | A # prefix or suffix allows semantically distinct wikilinks++ Typically called branching link or a tag link, when used with #.+-}+data WikiLinkType+  = -- | [[Foo]]+    WikiLinkNormal+  | -- | [[Foo]]#+    WikiLinkBranch+  | -- | #[[Foo]]+    WikiLinkTag+  | -- | ![[Foo]]+    WikiLinkEmbed+  deriving stock (Eq, Show, Ord, Typeable, Data, Enum, Bounded, Generic)+  deriving anyclass (ToJSON)++instance Read WikiLinkType where+  readsPrec _ s+    | s == show WikiLinkNormal = [(WikiLinkNormal, "")]+    | s == show WikiLinkBranch = [(WikiLinkBranch, "")]+    | s == show WikiLinkTag = [(WikiLinkTag, "")]+    | s == show WikiLinkEmbed = [(WikiLinkEmbed, "")]+    | otherwise = []++-- | The HTML 'data attribute' storing the wiki-link type.+htmlAttr :: Text+htmlAttr = "data-wikilink-type"++class HasWikiLink il where+  wikilink :: WikiLinkType -> WikiLink -> Maybe il -> il++instance HasWikiLink (CP.Cm b B.Inlines) where+  wikilink typ wl il =+    CP.Cm $ wikilinkInline typ wl $ maybe mempty CP.unCm il++{- | Like `Commonmark.Extensions.Wikilinks.wikilinkSpec` but Zettelkasten-friendly.++ Compared with the official extension, this has two differences:++ - Supports flipped inner text, eg: `[[Foo | some inner text]]`+ - Supports neuron folgezettel, i.e.: #[[Foo]] or [[Foo]]#+-}+wikilinkSpec ::+  (Monad m, CM.IsInline il, HasWikiLink il) =>+  CM.SyntaxSpec m il bl+wikilinkSpec =+  mempty+    { CM.syntaxInlineParsers =+        [ P.try $+            P.choice+              [ P.try (CT.symbol '#' *> pWikilink WikiLinkTag)+              , P.try (CT.symbol '!' *> pWikilink WikiLinkEmbed)+              , P.try (pWikilink WikiLinkBranch <* CT.symbol '#')+              , P.try (pWikilink WikiLinkNormal)+              ]+        ]+    }+  where+    pWikilink typ = do+      replicateM_ 2 $ CT.symbol '['+      P.notFollowedBy (CT.symbol '[')+      url <-+        CM.untokenize <$> many (satisfyNoneOf [isPipe, isAnchor, isClose])+      wl <- mkWikiLinkFromUrl url+      -- We ignore the anchor until https://github.com/srid/emanote/discussions/105+      _anchor <-+        M.optional $+          CM.untokenize+            <$> ( CT.symbol '#'+                    *> many (satisfyNoneOf [isPipe, isClose])+                )+      title <-+        M.optional $+          -- TODO: Should parse as inline so link text can be formatted?+          CM.untokenize+            <$> ( CT.symbol '|'+                    *> many (satisfyNoneOf [isClose])+                )+      replicateM_ 2 $ CT.symbol ']'+      return $ wikilink typ wl (fmap CM.str title)+    satisfyNoneOf toks =+      CT.satisfyTok $ \t -> not $ or $ toks <&> \tok -> tok t+    isAnchor =+      isSymbol '#'+    isPipe =+      isSymbol '|'+    isClose =+      isSymbol ']'+    isSymbol c =+      CT.hasType (CM.Symbol c)++{- | Convert Pandoc AST inlines to raw text.++ TODO: extend on top of plainify from heist-extra+-}+plainify :: [B.Inline] -> Text+plainify = W.query $ \case+  B.Str x -> x+  B.Code _attr x -> x+  B.Space -> " "+  B.SoftBreak -> " "+  B.LineBreak -> " "+  -- TODO: if fmt is html, we should strip the html tags+  B.RawInline _fmt s -> s+  -- Ignore "wrapper" inlines like span.+  B.Span _ _ -> ""+  -- TODO: How to wrap math stuff here?+  B.Math _mathTyp s -> s+  -- Wiki-links must be displayed using its show instance (which returns its+  -- human-readable representation)+  (mkWikiLinkFromInline -> Just (wl, customText)) ->+    if null customText+      then show wl -- We will display raw wikilink; ideally, though, we want to display the title.+      else plainify customText+  -- Ignore the rest of AST nodes, as they are recursively defined in terms of+  -- `Inline` which `W.query` will traverse again.+  _ -> ""