-- | A primitive module to eventually pave way towards first-class "calendar"
-- (daily notes, etc.) support in Emanote; either built-in or as plugin.
module Emanote.Model.Calendar where

import Data.Time.Calendar (Day, fromGregorianValid)
import Emanote.Model.Note qualified as N
import Emanote.Model.Title (Title)
import Emanote.Model.Type (Model, modelLookupTitle)
import Emanote.Route (LMLRoute)
import Emanote.Route qualified as R
import Relude
import Text.Megaparsec qualified as M
import Text.Megaparsec.Char qualified as M

-- HACK: This is so that calendar backlinks are sorted properly.
backlinkSortKey :: Model -> LMLRoute -> Down Title
backlinkSortKey :: Model -> LMLRoute -> Down Title
backlinkSortKey Model
model =
  Title -> Down Title
forall a. a -> Down a
Down (Title -> Down Title)
-> (LMLRoute -> Title) -> LMLRoute -> Down Title
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LMLRoute -> Model -> Title) -> Model -> LMLRoute -> Title
forall a b c. (a -> b -> c) -> b -> a -> c
flip LMLRoute -> Model -> Title
forall (f :: Type -> Type). LMLRoute -> ModelT f -> Title
modelLookupTitle Model
model

-- HACK: Until we have a proper search support. This sorts query results for
-- timeline
noteSortKey :: N.Note -> (Down (Maybe Text), LMLRoute)
noteSortKey :: Note -> (Down (Maybe Text), LMLRoute)
noteSortKey Note
note =
  (Maybe Text -> Down (Maybe Text)
forall a. a -> Down a
Down (Maybe Text -> Down (Maybe Text))
-> Maybe Text -> Down (Maybe Text)
forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => NonEmpty Text -> Note -> Maybe a
N.lookupMeta @Text (OneItem (NonEmpty Text) -> NonEmpty Text
forall x. One x => OneItem x -> x
one OneItem (NonEmpty Text)
"date") Note
note, Note -> LMLRoute
N._noteRoute Note
note)

isDailyNote :: LMLRoute -> Bool
isDailyNote :: LMLRoute -> Bool
isDailyNote =
  Maybe Day -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Day -> Bool) -> (LMLRoute -> Maybe Day) -> LMLRoute -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LMLRoute -> Maybe Day
parseRouteDay

parseRouteDay :: LMLRoute -> Maybe Day
parseRouteDay :: LMLRoute -> Maybe Day
parseRouteDay =
  Parsec Void Text Day -> Text -> Maybe Day
forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
M.parseMaybe Parsec Void Text Day
parse (Text -> Maybe Day) -> (LMLRoute -> Text) -> LMLRoute -> Maybe Day
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> Text)
-> LMLRoute -> Text
forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute forall {a} (ext :: FileType a). R @a ext -> Text
forall (lmlType :: LML).
HasExt @SourceExt ('LMLType lmlType) =>
R @SourceExt ('LMLType lmlType) -> Text
R.routeBaseName
  where
    parse :: M.Parsec Void Text Day
    parse :: Parsec Void Text Day
parse = do
      let asInt :: String -> ParsecT Void Text Identity Integer
asInt = ParsecT Void Text Identity Integer
-> (Integer -> ParsecT Void Text Identity Integer)
-> Maybe Integer
-> ParsecT Void Text Identity Integer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ParsecT Void Text Identity Integer
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Not an int") Integer -> ParsecT Void Text Identity Integer
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Integer -> ParsecT Void Text Identity Integer)
-> (String -> Maybe Integer)
-> String
-> ParsecT Void Text Identity Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe
      -- Year
      Integer
year <- String -> ParsecT Void Text Identity Integer
asInt (String -> ParsecT Void Text Identity Integer)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Integer
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: Type -> Type) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 ParsecT Void Text Identity Char
forall e s (m :: Type -> Type).
(MonadParsec e s m, (Token s :: Type) ~ (Char :: Type)) =>
m (Token s)
M.digitChar
      ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"-"
      -- Month
      Integer
month <- String -> ParsecT Void Text Identity Integer
asInt (String -> ParsecT Void Text Identity Integer)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Integer
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: Type -> Type) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 ParsecT Void Text Identity Char
forall e s (m :: Type -> Type).
(MonadParsec e s m, (Token s :: Type) ~ (Char :: Type)) =>
m (Token s)
M.digitChar
      ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: Type -> Type).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
M.string Tokens Text
"-"
      -- Day
      Integer
day <- String -> ParsecT Void Text Identity Integer
asInt (String -> ParsecT Void Text Identity Integer)
-> ParsecT Void Text Identity String
-> ParsecT Void Text Identity Integer
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: Type -> Type) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 ParsecT Void Text Identity Char
forall e s (m :: Type -> Type).
(MonadParsec e s m, (Token s :: Type) ~ (Char :: Type)) =>
m (Token s)
M.digitChar
      Parsec Void Text Day
-> (Day -> Parsec Void Text Day)
-> Maybe Day
-> Parsec Void Text Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parsec Void Text Day
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Not a date") Day -> Parsec Void Text Day
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Day -> Parsec Void Text Day)
-> Maybe Day -> Parsec Void Text Day
forall a b. (a -> b) -> a -> b
$
        Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
year (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
month) (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
day)