{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Special Zettel links in Markdown
module Neuron.Zettelkasten.Link.Action where

import Control.Foldl (Fold (..))
import qualified Data.Set as Set
import Neuron.Zettelkasten.ID
import Neuron.Zettelkasten.Query
import Neuron.Zettelkasten.Store
import Relude
import Text.MMark (MMark, runScanner)
import qualified Text.MMark.Extension as Ext
import Text.MMark.Extension (Inline (..))
import qualified Text.URI as URI

data LinkTheme
  = LinkTheme_Default
  | LinkTheme_Simple
  | LinkTheme_WithDate
  deriving (LinkTheme -> LinkTheme -> Bool
(LinkTheme -> LinkTheme -> Bool)
-> (LinkTheme -> LinkTheme -> Bool) -> Eq LinkTheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinkTheme -> LinkTheme -> Bool
$c/= :: LinkTheme -> LinkTheme -> Bool
== :: LinkTheme -> LinkTheme -> Bool
$c== :: LinkTheme -> LinkTheme -> Bool
Eq, Int -> LinkTheme -> ShowS
[LinkTheme] -> ShowS
LinkTheme -> String
(Int -> LinkTheme -> ShowS)
-> (LinkTheme -> String)
-> ([LinkTheme] -> ShowS)
-> Show LinkTheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinkTheme] -> ShowS
$cshowList :: [LinkTheme] -> ShowS
show :: LinkTheme -> String
$cshow :: LinkTheme -> String
showsPrec :: Int -> LinkTheme -> ShowS
$cshowsPrec :: Int -> LinkTheme -> ShowS
Show, Eq LinkTheme
Eq LinkTheme =>
(LinkTheme -> LinkTheme -> Ordering)
-> (LinkTheme -> LinkTheme -> Bool)
-> (LinkTheme -> LinkTheme -> Bool)
-> (LinkTheme -> LinkTheme -> Bool)
-> (LinkTheme -> LinkTheme -> Bool)
-> (LinkTheme -> LinkTheme -> LinkTheme)
-> (LinkTheme -> LinkTheme -> LinkTheme)
-> Ord LinkTheme
LinkTheme -> LinkTheme -> Bool
LinkTheme -> LinkTheme -> Ordering
LinkTheme -> LinkTheme -> LinkTheme
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LinkTheme -> LinkTheme -> LinkTheme
$cmin :: LinkTheme -> LinkTheme -> LinkTheme
max :: LinkTheme -> LinkTheme -> LinkTheme
$cmax :: LinkTheme -> LinkTheme -> LinkTheme
>= :: LinkTheme -> LinkTheme -> Bool
$c>= :: LinkTheme -> LinkTheme -> Bool
> :: LinkTheme -> LinkTheme -> Bool
$c> :: LinkTheme -> LinkTheme -> Bool
<= :: LinkTheme -> LinkTheme -> Bool
$c<= :: LinkTheme -> LinkTheme -> Bool
< :: LinkTheme -> LinkTheme -> Bool
$c< :: LinkTheme -> LinkTheme -> Bool
compare :: LinkTheme -> LinkTheme -> Ordering
$ccompare :: LinkTheme -> LinkTheme -> Ordering
$cp1Ord :: Eq LinkTheme
Ord)

data LinkAction
  = LinkAction_ConnectZettel Connection
  | -- | Render a list (or should it be tree?) of links to queries zettels
    -- TODO: Should this automatically establish a connection in graph??
    LinkAction_QueryZettels Connection LinkTheme [Query]
  deriving (LinkAction -> LinkAction -> Bool
(LinkAction -> LinkAction -> Bool)
-> (LinkAction -> LinkAction -> Bool) -> Eq LinkAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LinkAction -> LinkAction -> Bool
$c/= :: LinkAction -> LinkAction -> Bool
== :: LinkAction -> LinkAction -> Bool
$c== :: LinkAction -> LinkAction -> Bool
Eq, Int -> LinkAction -> ShowS
[LinkAction] -> ShowS
LinkAction -> String
(Int -> LinkAction -> ShowS)
-> (LinkAction -> String)
-> ([LinkAction] -> ShowS)
-> Show LinkAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LinkAction] -> ShowS
$cshowList :: [LinkAction] -> ShowS
show :: LinkAction -> String
$cshow :: LinkAction -> String
showsPrec :: Int -> LinkAction -> ShowS
$cshowsPrec :: Int -> LinkAction -> ShowS
Show)

linkActionFromUri :: URI.URI -> Maybe LinkAction
linkActionFromUri :: URI -> Maybe LinkAction
linkActionFromUri uri :: URI
uri =
  -- NOTE: We should probably drop the 'cf' variants in favour of specifying
  -- the connection type as a query param or something.
  case (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
uri) of
    Just "z" ->
      LinkAction -> Maybe LinkAction
forall a. a -> Maybe a
Just (LinkAction -> Maybe LinkAction) -> LinkAction -> Maybe LinkAction
forall a b. (a -> b) -> a -> b
$ Connection -> LinkAction
LinkAction_ConnectZettel Connection
Folgezettel
    Just "zcf" ->
      LinkAction -> Maybe LinkAction
forall a. a -> Maybe a
Just (LinkAction -> Maybe LinkAction) -> LinkAction -> Maybe LinkAction
forall a b. (a -> b) -> a -> b
$ Connection -> LinkAction
LinkAction_ConnectZettel Connection
OrdinaryConnection
    Just "zquery" ->
      LinkAction -> Maybe LinkAction
forall a. a -> Maybe a
Just (LinkAction -> Maybe LinkAction) -> LinkAction -> Maybe LinkAction
forall a b. (a -> b) -> a -> b
$ Connection -> LinkTheme -> [Query] -> LinkAction
LinkAction_QueryZettels Connection
Folgezettel (LinkTheme -> Maybe LinkTheme -> LinkTheme
forall a. a -> Maybe a -> a
fromMaybe LinkTheme
LinkTheme_Default (Maybe LinkTheme -> LinkTheme) -> Maybe LinkTheme -> LinkTheme
forall a b. (a -> b) -> a -> b
$ URI -> Maybe LinkTheme
linkThemeFromUri URI
uri) (URI -> [Query]
queryFromUri URI
uri)
    Just "zcfquery" ->
      LinkAction -> Maybe LinkAction
forall a. a -> Maybe a
Just (LinkAction -> Maybe LinkAction) -> LinkAction -> Maybe LinkAction
forall a b. (a -> b) -> a -> b
$ Connection -> LinkTheme -> [Query] -> LinkAction
LinkAction_QueryZettels Connection
OrdinaryConnection (LinkTheme -> Maybe LinkTheme -> LinkTheme
forall a. a -> Maybe a -> a
fromMaybe LinkTheme
LinkTheme_Default (Maybe LinkTheme -> LinkTheme) -> Maybe LinkTheme -> LinkTheme
forall a b. (a -> b) -> a -> b
$ URI -> Maybe LinkTheme
linkThemeFromUri URI
uri) (URI -> [Query]
queryFromUri URI
uri)
    _ ->
      Maybe LinkAction
forall a. Maybe a
Nothing

queryFromUri :: URI.URI -> [Query]
queryFromUri :: URI -> [Query]
queryFromUri uri :: URI
uri =
  ((QueryParam -> Maybe Query) -> [QueryParam] -> [Query])
-> [QueryParam] -> (QueryParam -> Maybe Query) -> [Query]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QueryParam -> Maybe Query) -> [QueryParam] -> [Query]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (URI -> [QueryParam]
URI.uriQuery URI
uri) ((QueryParam -> Maybe Query) -> [Query])
-> (QueryParam -> Maybe Query) -> [Query]
forall a b. (a -> b) -> a -> b
$ \case
    URI.QueryParam (RText 'QueryKey -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText -> Text
key) (RText 'QueryValue -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText -> Text
val) ->
      case Text
key of
        "tag" -> Query -> Maybe Query
forall a. a -> Maybe a
Just (Query -> Maybe Query) -> Query -> Maybe Query
forall a b. (a -> b) -> a -> b
$ Text -> Query
ByTag Text
val
        _ -> Maybe Query
forall a. Maybe a
Nothing
    _ -> Maybe Query
forall a. Maybe a
Nothing

linkThemeFromUri :: URI.URI -> Maybe LinkTheme
linkThemeFromUri :: URI -> Maybe LinkTheme
linkThemeFromUri uri :: URI
uri =
  [LinkTheme] -> Maybe LinkTheme
forall a. [a] -> Maybe a
listToMaybe ([LinkTheme] -> Maybe LinkTheme) -> [LinkTheme] -> Maybe LinkTheme
forall a b. (a -> b) -> a -> b
$ ((QueryParam -> Maybe LinkTheme) -> [QueryParam] -> [LinkTheme])
-> [QueryParam] -> (QueryParam -> Maybe LinkTheme) -> [LinkTheme]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QueryParam -> Maybe LinkTheme) -> [QueryParam] -> [LinkTheme]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (URI -> [QueryParam]
URI.uriQuery URI
uri) ((QueryParam -> Maybe LinkTheme) -> [LinkTheme])
-> (QueryParam -> Maybe LinkTheme) -> [LinkTheme]
forall a b. (a -> b) -> a -> b
$ \case
    URI.QueryFlag _ -> Maybe LinkTheme
forall a. Maybe a
Nothing
    URI.QueryParam (RText 'QueryKey -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText -> Text
key) (RText 'QueryValue -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText -> Text
val) ->
      case Text
key of
        "linkTheme" ->
          case Text
val of
            "default" -> LinkTheme -> Maybe LinkTheme
forall a. a -> Maybe a
Just LinkTheme
LinkTheme_Default
            "simple" -> LinkTheme -> Maybe LinkTheme
forall a. a -> Maybe a
Just LinkTheme
LinkTheme_Simple
            "withDate" -> LinkTheme -> Maybe LinkTheme
forall a. a -> Maybe a
Just LinkTheme
LinkTheme_WithDate
            _ -> Text -> Maybe LinkTheme
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Maybe LinkTheme) -> Text -> Maybe LinkTheme
forall a b. (a -> b) -> a -> b
$ "Unknown link theme: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val
        _ -> Maybe LinkTheme
forall a. Maybe a
Nothing

data MarkdownLink
  = MarkdownLink
      { MarkdownLink -> Text
markdownLinkText :: Text,
        MarkdownLink -> URI
markdownLinkUri :: URI.URI
      }
  deriving (MarkdownLink -> MarkdownLink -> Bool
(MarkdownLink -> MarkdownLink -> Bool)
-> (MarkdownLink -> MarkdownLink -> Bool) -> Eq MarkdownLink
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MarkdownLink -> MarkdownLink -> Bool
$c/= :: MarkdownLink -> MarkdownLink -> Bool
== :: MarkdownLink -> MarkdownLink -> Bool
$c== :: MarkdownLink -> MarkdownLink -> Bool
Eq, Eq MarkdownLink
Eq MarkdownLink =>
(MarkdownLink -> MarkdownLink -> Ordering)
-> (MarkdownLink -> MarkdownLink -> Bool)
-> (MarkdownLink -> MarkdownLink -> Bool)
-> (MarkdownLink -> MarkdownLink -> Bool)
-> (MarkdownLink -> MarkdownLink -> Bool)
-> (MarkdownLink -> MarkdownLink -> MarkdownLink)
-> (MarkdownLink -> MarkdownLink -> MarkdownLink)
-> Ord MarkdownLink
MarkdownLink -> MarkdownLink -> Bool
MarkdownLink -> MarkdownLink -> Ordering
MarkdownLink -> MarkdownLink -> MarkdownLink
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MarkdownLink -> MarkdownLink -> MarkdownLink
$cmin :: MarkdownLink -> MarkdownLink -> MarkdownLink
max :: MarkdownLink -> MarkdownLink -> MarkdownLink
$cmax :: MarkdownLink -> MarkdownLink -> MarkdownLink
>= :: MarkdownLink -> MarkdownLink -> Bool
$c>= :: MarkdownLink -> MarkdownLink -> Bool
> :: MarkdownLink -> MarkdownLink -> Bool
$c> :: MarkdownLink -> MarkdownLink -> Bool
<= :: MarkdownLink -> MarkdownLink -> Bool
$c<= :: MarkdownLink -> MarkdownLink -> Bool
< :: MarkdownLink -> MarkdownLink -> Bool
$c< :: MarkdownLink -> MarkdownLink -> Bool
compare :: MarkdownLink -> MarkdownLink -> Ordering
$ccompare :: MarkdownLink -> MarkdownLink -> Ordering
$cp1Ord :: Eq MarkdownLink
Ord)

linkActionConnections :: ZettelStore -> MarkdownLink -> [ZettelConnection]
linkActionConnections :: ZettelStore -> MarkdownLink -> [ZettelConnection]
linkActionConnections store :: ZettelStore
store MarkdownLink {..} =
  case URI -> Maybe LinkAction
linkActionFromUri URI
markdownLinkUri of
    Just (LinkAction_ConnectZettel conn :: Connection
conn) ->
      let zid :: ZettelID
zid = Text -> ZettelID
parseZettelID Text
markdownLinkText
       in [(Connection
conn, ZettelID
zid)]
    Just (LinkAction_QueryZettels conn :: Connection
conn _linkTheme :: LinkTheme
_linkTheme q :: [Query]
q) ->
      (Connection
conn,) (ZettelID -> ZettelConnection)
-> (Match -> ZettelID) -> Match -> ZettelConnection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match -> ZettelID
matchID (Match -> ZettelConnection) -> [Match] -> [ZettelConnection]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ZettelStore -> [Query] -> [Match]
runQuery ZettelStore
store [Query]
q
    Nothing ->
      []

-- | Extract all links from the Markdown document
extractLinks :: MMark -> [MarkdownLink]
extractLinks :: MMark -> [MarkdownLink]
extractLinks = Set MarkdownLink -> [MarkdownLink]
forall a. Set a -> [a]
Set.toList (Set MarkdownLink -> [MarkdownLink])
-> (MMark -> Set MarkdownLink) -> MMark -> [MarkdownLink]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MarkdownLink] -> Set MarkdownLink
forall a. Ord a => [a] -> Set a
Set.fromList ([MarkdownLink] -> Set MarkdownLink)
-> (MMark -> [MarkdownLink]) -> MMark -> Set MarkdownLink
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MMark -> Fold Bni [MarkdownLink] -> [MarkdownLink])
-> Fold Bni [MarkdownLink] -> MMark -> [MarkdownLink]
forall a b c. (a -> b -> c) -> b -> a -> c
flip MMark -> Fold Bni [MarkdownLink] -> [MarkdownLink]
forall a. MMark -> Fold Bni a -> a
runScanner (([MarkdownLink] -> Bni -> [MarkdownLink])
-> [MarkdownLink]
-> ([MarkdownLink] -> [MarkdownLink])
-> Fold Bni [MarkdownLink]
forall a b x. (x -> a -> x) -> x -> (x -> b) -> Fold a b
Fold [MarkdownLink] -> Bni -> [MarkdownLink]
go [] [MarkdownLink] -> [MarkdownLink]
forall a. a -> a
id)
  where
    go :: [MarkdownLink] -> Bni -> [MarkdownLink]
go acc :: [MarkdownLink]
acc blk :: Bni
blk = [MarkdownLink]
acc [MarkdownLink] -> [MarkdownLink] -> [MarkdownLink]
forall a. Semigroup a => a -> a -> a
<> [[MarkdownLink]] -> [MarkdownLink]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Inline -> [MarkdownLink]) -> [Inline] -> [[MarkdownLink]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Inline -> [MarkdownLink]
f (Bni -> [Inline]
forall a. Block (NonEmpty a) -> [a]
relevantInlines Bni
blk))
    f :: Inline -> [MarkdownLink]
f = \case
      Link inner :: NonEmpty Inline
inner uri :: URI
uri _title :: Maybe Text
_title ->
        [Text -> URI -> MarkdownLink
MarkdownLink (NonEmpty Inline -> Text
Ext.asPlainText NonEmpty Inline
inner) URI
uri]
      _ ->
        []
    relevantInlines :: Block (NonEmpty a) -> [a]
relevantInlines = \case
      Ext.Naked xs :: NonEmpty a
xs -> NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
xs
      Ext.Paragraph xs :: NonEmpty a
xs -> NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
xs
      Ext.OrderedList _ xs :: NonEmpty [Block (NonEmpty a)]
xs -> [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ NonEmpty [[a]] -> [[a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NonEmpty [[a]] -> [[a]]) -> NonEmpty [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([Block (NonEmpty a)] -> [[a]])
-> NonEmpty [Block (NonEmpty a)] -> NonEmpty [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Block (NonEmpty a) -> [a]) -> [Block (NonEmpty a)] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block (NonEmpty a) -> [a]
relevantInlines) NonEmpty [Block (NonEmpty a)]
xs
      Ext.UnorderedList xs :: NonEmpty [Block (NonEmpty a)]
xs -> [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ NonEmpty [[a]] -> [[a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (NonEmpty [[a]] -> [[a]]) -> NonEmpty [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([Block (NonEmpty a)] -> [[a]])
-> NonEmpty [Block (NonEmpty a)] -> NonEmpty [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Block (NonEmpty a) -> [a]) -> [Block (NonEmpty a)] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block (NonEmpty a) -> [a]
relevantInlines) NonEmpty [Block (NonEmpty a)]
xs
      _ -> []