{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Gemoire.Template
-- Copyright   :  (c) 2024 Sena
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  contact@sena.pink
-- Stability   :  stable
-- Portability :  portable
--
-- A minimal template parser to use with generated static gemlogs
--
-- Gemoire uses its own template system, where the templates are plain texts
-- with special inline components. The valid components are:
--
--     * @{$pholder$}@ - A placeholder with the key @pholder@
--     * @{$pholder:default value$}@ - A placeholder with a default value
--     * @{&pholder:fallback&}@ - With a fallback /key/ to use in case @pholder@ has no value
--     * @{&pholder:fallback:default value&}@ - With a fallback /key/ and a default /value/
--     * @{# comment! #}@ - An unrendered comment
--     * @{\\ constant \\}@ - An unevaluated block, akin to escaping things inside it
--
-- All inline components can be multiline in any way, including placeholder keys.
-- The arguments can also be surrounded by any amount of whitespace, which will
-- get stripped /except/ when specifying a default value.
--
-- The surrounding braces are parsed in order, so the components /can not/ be nested.
module Gemoire.Template
    ( -- * Formatting
      template
    , format

      -- * Types
    , Values
    , Template
    , Component (..)

      -- * Utility
    , vempty
    , vlist
    ) where

import Control.Arrow (second, (&&&), (***))
import Control.Monad (join)
import Data.Bool (bool)
import Data.HashMap.Strict (HashMap, empty, findWithDefault, fromList, (!?))
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T

-- | A basic template, in the form of a string of either plain text
-- blocks or meaningful components
type Template = [Either Text Component]

-- | A parsed template component with a special meaning
data Component
    = -- | A placeholder with an optional default value
      Placeholder !Text !(Maybe Text)
    | -- | A placeholder with another key to fallback to if the first one
      -- has no value, and an optional default value
      Fallback !Text !Text !(Maybe Text)
    deriving (Component -> Component -> Bool
(Component -> Component -> Bool)
-> (Component -> Component -> Bool) -> Eq Component
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Component -> Component -> Bool
== :: Component -> Component -> Bool
$c/= :: Component -> Component -> Bool
/= :: Component -> Component -> Bool
Eq, Int -> Component -> ShowS
[Component] -> ShowS
Component -> String
(Int -> Component -> ShowS)
-> (Component -> String)
-> ([Component] -> ShowS)
-> Show Component
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Component -> ShowS
showsPrec :: Int -> Component -> ShowS
$cshow :: Component -> String
show :: Component -> String
$cshowList :: [Component] -> ShowS
showList :: [Component] -> ShowS
Show)

-- | An unordered `HashMap' of formatting keys and values
type Values = HashMap Text Text

-- | Construct a `Template' from the given `Text'.
--
-- See the module description for how the templates are formed.
--
-- The whitespaces in the arguments will be stripped /except/ for default values.
--
-- The surrounding braces are parsed in order, so the components /can not/ be nested.
template :: Text -> Template
template :: Text -> Template
template Text
text
    | Text -> Bool
T.null Text
text = []
    | Bool
otherwise =
        let (Text
str, ((Text
pfx, Text
inside), (Text
sfx, Text
rest))) =
                (Text -> ((Text, Text), (Text, Text)))
-> (Text, Text) -> (Text, ((Text, Text), (Text, Text)))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (((Text, Text), (Text, Text)) -> ((Text, Text), (Text, Text))
shiftDelimiters (((Text, Text), (Text, Text)) -> ((Text, Text), (Text, Text)))
-> (Text -> ((Text, Text), (Text, Text)))
-> Text
-> ((Text, Text), (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, 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)
-> ((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')
(***) (Int -> Text -> (Text, Text)
T.splitAt Int
1) ((Text, Text) -> ((Text, Text), (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, Text) -> (Text, ((Text, Text), (Text, Text)))
forall a b. (a -> b) -> a -> b
$
                    (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'{') Text
text
            optstr :: [Either Text b]
optstr = [Either Text b] -> [Either Text b] -> Bool -> [Either Text b]
forall a. a -> a -> Bool -> a
bool [Text -> Either Text b
forall a b. a -> Either a b
Left Text
str] [] (Bool -> [Either Text b]) -> Bool -> [Either Text b]
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
str
         in case (Text
pfx, Text
sfx) of
                (Text
"{$", Text
"$}") ->
                    let (Text
name, Maybe Text
def) = (Text -> Maybe Text) -> (Text, Text) -> (Text, Maybe Text)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Text -> Text -> Maybe Text
T.stripPrefix Text
":") ((Text, Text) -> (Text, Maybe Text))
-> (Text, Text) -> (Text, Maybe Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
inside
                     in Template
forall {b}. [Either Text b]
optstr Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> [Component -> Either Text Component
forall a b. b -> Either a b
Right (Component -> Either Text Component)
-> Component -> Either Text Component
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Component
Placeholder (Text -> Text
T.strip Text
name) Maybe Text
def] Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> Text -> Template
template Text
rest
                (Text
"{&", Text
"&}") ->
                    let (Text
name, (Text
fback, Maybe Text
def)) =
                            (Text -> (Text, Maybe Text))
-> (Text, Text) -> (Text, (Text, Maybe Text))
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Text -> Maybe Text) -> (Text, Text) -> (Text, Maybe Text)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Text -> Text -> Maybe Text
T.stripPrefix Text
":") ((Text, Text) -> (Text, Maybe Text))
-> (Text -> (Text, Text)) -> Text -> (Text, Maybe 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
. Int -> Text -> Text
T.drop Int
1) ((Text, Text) -> (Text, (Text, Maybe Text)))
-> (Text, Text) -> (Text, (Text, Maybe Text))
forall a b. (a -> b) -> a -> b
$
                                (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
inside
                     in Template
forall {b}. [Either Text b]
optstr Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> [Component -> Either Text Component
forall a b. b -> Either a b
Right (Component -> Either Text Component)
-> Component -> Either Text Component
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text -> Component
Fallback (Text -> Text
T.strip Text
name) (Text -> Text
T.strip Text
fback) Maybe Text
def] Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> Text -> Template
template Text
rest
                (Text
"{#", Text
_) ->
                    let (Text
_, Text
end) = (Text -> Text) -> (Text, Text) -> (Text, Text)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> Text -> Text
T.drop Int
2) ((Text, Text) -> (Text, Text)) -> (Text, Text) -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"#}" (Text
inside Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sfx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest)
                     in Template
forall {b}. [Either Text b]
optstr Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> Text -> Template
template Text
end
                (Text
"{\\", Text
_) ->
                    let (Text
constant, Text
end) = (Text -> Text) -> (Text, Text) -> (Text, Text)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Int -> Text -> Text
T.drop Int
2) ((Text, Text) -> (Text, Text)) -> (Text, Text) -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"\\}" (Text
inside Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sfx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rest)
                     in Template
forall {b}. [Either Text b]
optstr Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> [Text -> Either Text Component
forall a b. a -> Either a b
Left Text
constant] Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> Text -> Template
template Text
end
                (Text, Text)
_ -> [Text -> Either Text Component
forall a b. a -> Either a b
Left (Text
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pfx)] Template -> Template -> Template
forall a. Semigroup a => a -> a -> a
<> Text -> Template
template (Text
inside Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sfx)
  where
    shiftDelimiters :: ((Text, Text), (Text, Text)) -> ((Text, Text), (Text, Text))
    shiftDelimiters :: ((Text, Text), (Text, Text)) -> ((Text, Text), (Text, Text))
shiftDelimiters ((Text
pfx, Text
pholder), (Text
sfx, Text
rest)) =
        ( (((Text
pfx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.take Int
1) (Text -> Text) -> (Text -> Text) -> Text -> (Text, Text)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.dropEnd Int
1)) Text
pholder
        , (Int -> Text -> Text
T.takeEnd Int
1 Text
pholder Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sfx, Text
rest)
        )

-- | Format the `Template' using given `Values' map.
format :: Template -> Values -> Text
format :: Template -> Values -> Text
format [] Values
_ = Text
""
format (Either Text Component
p : Template
ps) Values
vars =
    ( case Either Text Component
p of
        Left Text
text -> Text
text
        Right (Placeholder Text
key Maybe Text
def) -> Text -> Text -> Values -> Text
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
findWithDefault (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
def) Text
key Values
vars
        Right (Fallback Text
key1 Text
key2 Maybe Text
def) ->
            Text -> Text -> Values -> Text
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
findWithDefault (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
def) (Values
vars Values -> Text -> Maybe Text
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> Maybe v
!? Text
key2)) Text
key1 Values
vars
    )
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Template -> Values -> Text
format Template
ps Values
vars

-- | An empty `Values' map for convenience
vempty :: Values
vempty :: Values
vempty = Values
forall k v. HashMap k v
empty

-- | `fromList' for convenience
vlist :: [(Text, Text)] -> Values
vlist :: [(Text, Text)] -> Values
vlist = [(Text, Text)] -> Values
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList