{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Neuron.Zettelkasten.ID
  ( ZettelID (..),
    Connection (..),
    ZettelConnection,
    zettelIDDate,
    parseZettelID,
    mkZettelID,
    zettelNextIdForToday,
    zettelIDSourceFileName,
  )
where

import Data.Aeson (ToJSON)
import qualified Data.Text as T
import Data.Time
import Lucid
import Path
import Relude
import System.Directory (listDirectory)
import qualified System.FilePattern as FP
import Text.Printf

-- | Short Zettel ID encoding `Day` and a numeric index (on that day).
--
-- Based on https://old.reddit.com/r/Zettelkasten/comments/fa09zw/shorter_zettel_ids/
newtype ZettelID = ZettelID {ZettelID -> Text
unZettelID :: Text}
  deriving (ZettelID -> ZettelID -> Bool
(ZettelID -> ZettelID -> Bool)
-> (ZettelID -> ZettelID -> Bool) -> Eq ZettelID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ZettelID -> ZettelID -> Bool
$c/= :: ZettelID -> ZettelID -> Bool
== :: ZettelID -> ZettelID -> Bool
$c== :: ZettelID -> ZettelID -> Bool
Eq, Int -> ZettelID -> ShowS
[ZettelID] -> ShowS
ZettelID -> String
(Int -> ZettelID -> ShowS)
-> (ZettelID -> String) -> ([ZettelID] -> ShowS) -> Show ZettelID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ZettelID] -> ShowS
$cshowList :: [ZettelID] -> ShowS
show :: ZettelID -> String
$cshow :: ZettelID -> String
showsPrec :: Int -> ZettelID -> ShowS
$cshowsPrec :: Int -> ZettelID -> ShowS
Show, Eq ZettelID
Eq ZettelID =>
(ZettelID -> ZettelID -> Ordering)
-> (ZettelID -> ZettelID -> Bool)
-> (ZettelID -> ZettelID -> Bool)
-> (ZettelID -> ZettelID -> Bool)
-> (ZettelID -> ZettelID -> Bool)
-> (ZettelID -> ZettelID -> ZettelID)
-> (ZettelID -> ZettelID -> ZettelID)
-> Ord ZettelID
ZettelID -> ZettelID -> Bool
ZettelID -> ZettelID -> Ordering
ZettelID -> ZettelID -> ZettelID
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 :: ZettelID -> ZettelID -> ZettelID
$cmin :: ZettelID -> ZettelID -> ZettelID
max :: ZettelID -> ZettelID -> ZettelID
$cmax :: ZettelID -> ZettelID -> ZettelID
>= :: ZettelID -> ZettelID -> Bool
$c>= :: ZettelID -> ZettelID -> Bool
> :: ZettelID -> ZettelID -> Bool
$c> :: ZettelID -> ZettelID -> Bool
<= :: ZettelID -> ZettelID -> Bool
$c<= :: ZettelID -> ZettelID -> Bool
< :: ZettelID -> ZettelID -> Bool
$c< :: ZettelID -> ZettelID -> Bool
compare :: ZettelID -> ZettelID -> Ordering
$ccompare :: ZettelID -> ZettelID -> Ordering
$cp1Ord :: Eq ZettelID
Ord, [ZettelID] -> Encoding
[ZettelID] -> Value
ZettelID -> Encoding
ZettelID -> Value
(ZettelID -> Value)
-> (ZettelID -> Encoding)
-> ([ZettelID] -> Value)
-> ([ZettelID] -> Encoding)
-> ToJSON ZettelID
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ZettelID] -> Encoding
$ctoEncodingList :: [ZettelID] -> Encoding
toJSONList :: [ZettelID] -> Value
$ctoJSONList :: [ZettelID] -> Value
toEncoding :: ZettelID -> Encoding
$ctoEncoding :: ZettelID -> Encoding
toJSON :: ZettelID -> Value
$ctoJSON :: ZettelID -> Value
ToJSON)

instance ToHtml ZettelID where
  toHtmlRaw :: ZettelID -> HtmlT m ()
toHtmlRaw = ZettelID -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml
  toHtml :: ZettelID -> HtmlT m ()
toHtml = Text -> HtmlT m ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> HtmlT m ())
-> (ZettelID -> Text) -> ZettelID -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZettelID -> Text
unZettelID

zettelIDSourceFileName :: ZettelID -> Text
zettelIDSourceFileName :: ZettelID -> Text
zettelIDSourceFileName zid :: ZettelID
zid = ZettelID -> Text
unZettelID ZettelID
zid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ".md"

-- TODO: sync/DRY with zettelNextIdForToday
zettelIDDate :: ZettelID -> Day
zettelIDDate :: ZettelID -> Day
zettelIDDate =
  Bool -> TimeLocale -> String -> String -> Day
forall t.
ParseTime t =>
Bool -> TimeLocale -> String -> String -> t
parseTimeOrError Bool
False TimeLocale
defaultTimeLocale "%y%W%a"
    (String -> Day) -> (ZettelID -> String) -> ZettelID -> Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString
    (Text -> String) -> (ZettelID -> Text) -> ZettelID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text) -> (Text, Text) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend
    ((Text, Text) -> Text)
-> (ZettelID -> (Text, Text)) -> ZettelID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Maybe Int -> Text
dayFromIndex (Maybe Int -> Text) -> (Text -> Maybe Int) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString)
    ((Text, Text) -> (Text, Text))
-> (ZettelID -> (Text, Text)) -> ZettelID -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.dropEnd 1 (Text -> Text) -> (Text -> Text) -> Text -> (Text, Text)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Int -> Text -> Text
T.takeEnd 1)
    (Text -> (Text, Text))
-> (ZettelID -> Text) -> ZettelID -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.dropEnd 2
    (Text -> Text) -> (ZettelID -> Text) -> ZettelID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZettelID -> Text
unZettelID
  where
    dayFromIndex :: Maybe Int -> Text
    dayFromIndex :: Maybe Int -> Text
dayFromIndex = \case
      Just n :: Int
n ->
        case Int
n of
          1 -> "Mon"
          2 -> "Tue"
          3 -> "Wed"
          4 -> "Thu"
          5 -> "Fri"
          6 -> "Sat"
          7 -> "Sun"
          _ -> Text -> Text
forall a t. (HasCallStack, IsText t) => t -> a
error "> 7"
      Nothing ->
        Text -> Text
forall a t. (HasCallStack, IsText t) => t -> a
error "Bad day"

zettelNextIdForToday :: Path b Dir -> IO ZettelID
zettelNextIdForToday :: Path b Dir -> IO ZettelID
zettelNextIdForToday inputDir :: Path b Dir
inputDir = Text -> ZettelID
ZettelID (Text -> ZettelID) -> IO Text -> IO ZettelID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  Text
zIdPartial <- Text -> Text
dayIndex (Text -> Text) -> (UTCTime -> Text) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%y%W%a" (UTCTime -> Text) -> IO UTCTime -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  [String]
zettelFiles <- String -> IO [String]
listDirectory (String -> IO [String]) -> String -> IO [String]
forall a b. (a -> b) -> a -> b
$ Path b Dir -> String
forall b t. Path b t -> String
toFilePath (Path b Dir -> String) -> Path b Dir -> String
forall a b. (a -> b) -> a -> b
$ Path b Dir
inputDir
  let [Int]
nums :: [Int] = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe Int) -> [String] -> [Maybe Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe ([String] -> [Maybe Int]) -> [String] -> [Maybe Int]
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> [Maybe String] -> [String]
forall a b. (a -> b) -> a -> b
$ [Maybe (Maybe String)] -> [Maybe String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Maybe String)] -> [Maybe String])
-> [Maybe (Maybe String)] -> [Maybe String]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (Maybe String))
-> [String] -> [Maybe (Maybe String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([String] -> Maybe String)
-> Maybe [String] -> Maybe (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe (Maybe [String] -> Maybe (Maybe String))
-> (String -> Maybe [String]) -> String -> Maybe (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Maybe [String]
FP.match (Text -> String
forall a. ToString a => a -> String
toString Text
zIdPartial String -> ShowS
forall a. Semigroup a => a -> a -> a
<> "*.md")) [String]
zettelFiles
  case (NonEmpty Int -> Int) -> Maybe (NonEmpty Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Int -> Int
forall (f :: * -> *) a. IsNonEmpty f a a "last" => f a -> a
last ([Int] -> Maybe (NonEmpty Int)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Int]
nums) of
    Just lastNum :: Int
lastNum ->
      Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
zIdPartial Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText @String (String -> Int -> String
forall r. PrintfType r => String -> r
printf "%02d" (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
lastNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
    Nothing ->
      Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
zIdPartial Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "01"
  where
    dayIndex :: Text -> Text
dayIndex =
      Text -> Text -> Text -> Text
T.replace "Mon" "1"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace "Tue" "2"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace "Wed" "3"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace "Thu" "4"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace "Fri" "5"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace "Sat" "6"
        (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace "Sun" "7"

-- TODO: Actually parse and validate
parseZettelID :: Text -> ZettelID
parseZettelID :: Text -> ZettelID
parseZettelID = Text -> ZettelID
ZettelID

-- | Extract ZettelID from the zettel's filename or path.
mkZettelID :: Path Rel File -> ZettelID
mkZettelID :: Path Rel File -> ZettelID
mkZettelID fp :: Path Rel File
fp = (SomeException -> ZettelID)
-> (ZettelID -> ZettelID)
-> Either SomeException ZettelID
-> ZettelID
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> ZettelID
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> ZettelID)
-> (SomeException -> Text) -> SomeException -> ZettelID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> (SomeException -> String) -> SomeException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall e. Exception e => e -> String
displayException) ZettelID -> ZettelID
forall a. a -> a
id (Either SomeException ZettelID -> ZettelID)
-> Either SomeException ZettelID -> ZettelID
forall a b. (a -> b) -> a -> b
$ do
  (name :: Path Rel File
name, _) <- Path Rel File -> Either SomeException (Path Rel File, String)
forall (m :: * -> *) b.
MonadThrow m =>
Path b File -> m (Path b File, String)
splitExtension (Path Rel File -> Either SomeException (Path Rel File, String))
-> Path Rel File -> Either SomeException (Path Rel File, String)
forall a b. (a -> b) -> a -> b
$ Path Rel File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Rel File
fp
  ZettelID -> Either SomeException ZettelID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZettelID -> Either SomeException ZettelID)
-> ZettelID -> Either SomeException ZettelID
forall a b. (a -> b) -> a -> b
$ Text -> ZettelID
ZettelID (Text -> ZettelID) -> Text -> ZettelID
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path Rel File -> String
forall b t. Path b t -> String
toFilePath Path Rel File
name

type ZettelConnection = (Connection, ZettelID)

-- | Represent the connection between zettels
data Connection
  = -- | A folgezettel points to a zettel that is conceptually a part of the
    -- parent zettel.
    Folgezettel
  | -- | Any other ordinary connection (eg: "See also")
    OrdinaryConnection
  deriving (Connection -> Connection -> Bool
(Connection -> Connection -> Bool)
-> (Connection -> Connection -> Bool) -> Eq Connection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Connection -> Connection -> Bool
$c/= :: Connection -> Connection -> Bool
== :: Connection -> Connection -> Bool
$c== :: Connection -> Connection -> Bool
Eq, Eq Connection
Eq Connection =>
(Connection -> Connection -> Ordering)
-> (Connection -> Connection -> Bool)
-> (Connection -> Connection -> Bool)
-> (Connection -> Connection -> Bool)
-> (Connection -> Connection -> Bool)
-> (Connection -> Connection -> Connection)
-> (Connection -> Connection -> Connection)
-> Ord Connection
Connection -> Connection -> Bool
Connection -> Connection -> Ordering
Connection -> Connection -> Connection
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 :: Connection -> Connection -> Connection
$cmin :: Connection -> Connection -> Connection
max :: Connection -> Connection -> Connection
$cmax :: Connection -> Connection -> Connection
>= :: Connection -> Connection -> Bool
$c>= :: Connection -> Connection -> Bool
> :: Connection -> Connection -> Bool
$c> :: Connection -> Connection -> Bool
<= :: Connection -> Connection -> Bool
$c<= :: Connection -> Connection -> Bool
< :: Connection -> Connection -> Bool
$c< :: Connection -> Connection -> Bool
compare :: Connection -> Connection -> Ordering
$ccompare :: Connection -> Connection -> Ordering
$cp1Ord :: Eq Connection
Ord, Int -> Connection -> ShowS
[Connection] -> ShowS
Connection -> String
(Int -> Connection -> ShowS)
-> (Connection -> String)
-> ([Connection] -> ShowS)
-> Show Connection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Connection] -> ShowS
$cshowList :: [Connection] -> ShowS
show :: Connection -> String
$cshow :: Connection -> String
showsPrec :: Int -> Connection -> ShowS
$cshowsPrec :: Int -> Connection -> ShowS
Show, Int -> Connection
Connection -> Int
Connection -> [Connection]
Connection -> Connection
Connection -> Connection -> [Connection]
Connection -> Connection -> Connection -> [Connection]
(Connection -> Connection)
-> (Connection -> Connection)
-> (Int -> Connection)
-> (Connection -> Int)
-> (Connection -> [Connection])
-> (Connection -> Connection -> [Connection])
-> (Connection -> Connection -> [Connection])
-> (Connection -> Connection -> Connection -> [Connection])
-> Enum Connection
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Connection -> Connection -> Connection -> [Connection]
$cenumFromThenTo :: Connection -> Connection -> Connection -> [Connection]
enumFromTo :: Connection -> Connection -> [Connection]
$cenumFromTo :: Connection -> Connection -> [Connection]
enumFromThen :: Connection -> Connection -> [Connection]
$cenumFromThen :: Connection -> Connection -> [Connection]
enumFrom :: Connection -> [Connection]
$cenumFrom :: Connection -> [Connection]
fromEnum :: Connection -> Int
$cfromEnum :: Connection -> Int
toEnum :: Int -> Connection
$ctoEnum :: Int -> Connection
pred :: Connection -> Connection
$cpred :: Connection -> Connection
succ :: Connection -> Connection
$csucc :: Connection -> Connection
Enum, Connection
Connection -> Connection -> Bounded Connection
forall a. a -> a -> Bounded a
maxBound :: Connection
$cmaxBound :: Connection
minBound :: Connection
$cminBound :: Connection
Bounded)