{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Gemoire.Gemlog.Post
-- Copyright   :  (c) 2024 Sena
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  contact@sena.pink
-- Stability   :  stable
-- Portability :  portable
--
-- Minimal gemlog post parser/formatter and default templates
--
-- For posts, the template components are also usable, following the same
-- syntax described in `Gemoire.Template'. Variables available to the post will
-- be applied while parsing like in templates.
--
-- The variables available in a post /may/ change depending on what function parses
-- them. Unless doing heavy customization, see `Gemoire.Gemlog' for the variables
-- available in the intended use. Otherwise, see each function below.
--
-- Additionally, variables can also be set (or overridden) in the post like so,
-- assuming a /single variable per line/:
--
--     > {= variable value =}
module Gemoire.Gemlog.Post
    ( -- * Parsers
      parsePost
    , readPost

      -- * Templates
    , defPost
    ) where

import Control.Arrow ((***))
import Control.Monad (join)
import Data.Bool (bool)
import qualified Data.HashMap.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Time (UTCTime (..), utc, utcToZonedTime)
import Data.Time.Format.ISO8601 (iso8601Show)
import System.Directory (getModificationTime)
import System.FilePath (takeBaseName)
import Text.Gemini (GemDocument, GemItem (..))
import qualified Text.Gemini as G

import Gemoire.Template (Template, Values, format, template)

defPost :: Template
defPost :: Template
defPost = Text -> Template
template Text
"{$post$}\CR\LF"

-- | Parses a GemText post into a map of `Values' to use in templates.
--
-- The post content will be evaluated and formatted using `template' and
-- `format' before creating the map.
--
-- Some special variables are also generated while parsing. Those are:
--
--     * @title@ - The first heading in the document if it exists
--     * @post@ - The post content (non-overrideable by the post text)
parsePost
    :: Values
    -- ^ Extra variable overrides
    -> Text
    -> Values
parsePost :: Values -> Text -> Values
parsePost Values
extras Text
text = Values -> GemDocument -> GemDocument -> Values
parse Values
forall k v. HashMap k v
M.empty [] GemDocument
doc
  where
    doc :: GemDocument
doc = Text -> GemDocument
G.decode Text
text

    parse :: Values -> GemDocument -> [GemItem] -> Values
    parse :: Values -> GemDocument -> GemDocument -> Values
parse Values
vars GemDocument
post (GemItem
i : GemDocument
is) = case GemItem
i of
        GemText Text
line -> case Text -> Maybe (Text, Text)
getVariable Text
line of
            Just (Text, Text)
pair -> Values -> GemDocument -> GemDocument -> Values
parse ((Text -> Text -> Values -> Values)
-> (Text, Text) -> Values -> Values
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Values -> Values
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert (Text, Text)
pair Values
vars) GemDocument
post GemDocument
is
            Maybe (Text, Text)
Nothing -> Values -> GemDocument -> GemDocument -> Values
parse Values
vars (GemDocument
post GemDocument -> GemDocument -> GemDocument
forall a. Semigroup a => a -> a -> a
<> [Text -> GemItem
GemText Text
line]) GemDocument
is
        GemItem
line -> Values -> GemDocument -> GemDocument -> Values
parse Values
vars (GemDocument
post GemDocument -> GemDocument -> GemDocument
forall a. Semigroup a => a -> a -> a
<> [GemItem
line]) GemDocument
is
    parse Values
vars GemDocument
post [] =
        let title :: Values
title = Values -> (Text -> Values) -> Maybe Text -> Values
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Values
forall k v. HashMap k v
M.empty (Text -> Text -> Values
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton Text
"title") (Maybe Text -> Values) -> Maybe Text -> Values
forall a b. (a -> b) -> a -> b
$ GemDocument -> Maybe Text
G.documentTitle GemDocument
doc
            recursive :: Values
recursive = Values
extras Values -> Values -> Values
forall a. Semigroup a => a -> a -> a
<> Values
vars Values -> Values -> Values
forall a. Semigroup a => a -> a -> a
<> Values
title
            content :: Values
content =
                Text -> Text -> Values
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton Text
"post"
                    (Text -> Values) -> Text -> Values
forall a b. (a -> b) -> a -> b
$ Text -> Text
stripFinalNewline
                        (Text -> Text) -> (GemDocument -> Text) -> GemDocument -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Template -> Values -> Text
`format` Values
recursive)
                        (Template -> Text)
-> (GemDocument -> Template) -> GemDocument -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Template
template
                        (Text -> Template)
-> (GemDocument -> Text) -> GemDocument -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GemDocument -> Text
G.encode
                    (GemDocument -> Text) -> GemDocument -> Text
forall a b. (a -> b) -> a -> b
$ GemDocument
post
         in Values
extras Values -> Values -> Values
forall a. Semigroup a => a -> a -> a
<> Values
content Values -> Values -> Values
forall a. Semigroup a => a -> a -> a
<> Values
vars Values -> Values -> Values
forall a. Semigroup a => a -> a -> a
<> Values
title

-- | Reads and parses a GemText post file into a map of `Values' to use in templates.
--
-- See `parsePost' for how this function works. Everything there applies here as well.
-- This function adds some additional formatting variables, which are:
--
--     * @path@ - The given file path
--     * @fname@ - The file name without the extension and the directories
--     * @modified@ - File modification date and time (@yyyy-mm-ddThh:mm:ss[.ss]±hh:mm@)
--     * @modified_date@ - File modification date (@yyyy-mm-dd@)
--
-- These variables are /not/ overrideable by the post text.
readPost
    :: Values
    -- ^ Extra variable overrides
    -> FilePath
    -> IO Values
readPost :: Values -> FilePath -> IO Values
readPost Values
extras FilePath
path = do
    UTCTime
modified <- UTCTime -> UTCTime
stripTime (UTCTime -> UTCTime) -> IO UTCTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO UTCTime
getModificationTime FilePath
path
    let modifiedStr :: Text
modifiedStr = FilePath -> Text
T.pack (FilePath -> Text) -> (UTCTime -> FilePath) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZonedTime -> FilePath
forall t. ISO8601 t => t -> FilePath
iso8601Show (ZonedTime -> FilePath)
-> (UTCTime -> ZonedTime) -> UTCTime -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
utc (UTCTime -> Text) -> UTCTime -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime
modified
        modifiedDate :: Text
modifiedDate = FilePath -> Text
T.pack (FilePath -> Text) -> (UTCTime -> FilePath) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> FilePath
forall t. ISO8601 t => t -> FilePath
iso8601Show (Day -> FilePath) -> (UTCTime -> Day) -> UTCTime -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Day
utctDay (UTCTime -> Text) -> UTCTime -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime
modified
     in Values -> Text -> Values
parsePost
            ( Values
extras
                Values -> Values -> Values
forall a. Semigroup a => a -> a -> a
<> [(Text, Text)] -> Values
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList
                    [ (Text
"path", FilePath -> Text
T.pack FilePath
path)
                    , (Text
"fname", FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeBaseName (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
path)
                    , (Text
"modified", Text
modifiedStr)
                    , (Text
"modified_date", Text
modifiedDate)
                    ]
            )
            (Text -> Values) -> IO Text -> IO Values
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
TIO.readFile FilePath
path

-- Get the variable value if it exists.
getVariable :: Text -> Maybe (Text, Text)
getVariable :: Text -> Maybe (Text, Text)
getVariable Text
line =
    (\(Text, Text)
v -> Maybe (Text, Text)
-> Maybe (Text, Text) -> Bool -> Maybe (Text, Text)
forall a. a -> a -> Bool -> a
bool ((Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text, Text)
v) Maybe (Text, Text)
forall a. Maybe a
Nothing (Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text, Text)
v))
        ((Text, Text) -> Maybe (Text, Text))
-> (Text -> (Text, Text)) -> Text -> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text -> Text) -> (Text -> Text) -> (Text, Text) -> (Text, Text))
-> (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> Text) -> (Text -> Text) -> (Text, Text) -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) Text -> Text
T.strip
        ((Text, Text) -> (Text, Text))
-> (Text -> (Text, Text)) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
        (Text -> (Text, Text)) -> (Text -> Text) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
        (Text -> Maybe (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Text -> Text -> Maybe Text
T.stripPrefix Text
"{=" Text
line Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Maybe Text
T.stripSuffix Text
"=}")

-- Strip the final newline from text if it exists.
stripFinalNewline :: Text -> Text
stripFinalNewline :: Text -> Text
stripFinalNewline Text
text
    | Text
"\CR\LF" Text -> Text -> Bool
`T.isSuffixOf` Text
text = Int -> Text -> Text
T.dropEnd Int
2 Text
text
    | Text
"\LF" Text -> Text -> Bool
`T.isSuffixOf` Text
text = Int -> Text -> Text
T.dropEnd Int
1 Text
text
    | Bool
otherwise = Text
text

-- Strip the picosecond precision from time.
stripTime :: UTCTime -> UTCTime
stripTime :: UTCTime -> UTCTime
stripTime (UTCTime Day
day DiffTime
time) = Day -> DiffTime -> UTCTime
UTCTime Day
day (DiffTime -> UTCTime) -> DiffTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
forall a. Num a => Integer -> a
fromInteger (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> Integer
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor DiffTime
time