-- |
--
-- Copyright:
--   This file is part of the package vimeta. It is subject to the
--   license terms in the LICENSE file found in the top-level
--   directory of this distribution and at:
--
--     https://github.com/pjones/vimeta
--
--   No part of this package, including this file, may be copied,
--   modified, propagated, or distributed except according to the terms
--   contained in the LICENSE file.
--
-- License: BSD-2-Clause
module Vimeta.Core.Format
  ( FormatTable,
    fromFormatString,
    formatYear,
    formatFullDate,
  )
where

import Data.Time (Day (..), defaultTimeLocale, formatTime)
import Relude.Extra.Map
import System.Process.Internals (translate)
import Text.Parsec hiding ((<|>))

-- | Mapping of format characters to their possible replacement text.
type FormatTable = Map Char (Maybe Text)

-- | Syntax tree for format strings.
data Replacement
  = -- | Replace the given character.
    Replace Char
  | -- | Conditional section.
    Condition [(Text, Replacement)]
  | -- | End of input (or condition).
    EndOfInput

-- | Parser type.
type Parser a = ParsecT Text () (Reader FormatTable) a

-- | Replace format characters prefixed with a @%@ with the
-- replacement text found in the given 'Map'.
fromFormatString ::
  -- | Format character mapping.
  FormatTable ->
  -- | Name of format string.
  String ->
  -- | Input text.
  Text ->
  -- | Output text or error.
  Either String Text
fromFormatString :: FormatTable -> String -> Text -> Either String Text
fromFormatString FormatTable
table String
name Text
input =
  case Reader FormatTable (Either ParseError Text)
-> FormatTable -> Either ParseError Text
forall r a. Reader r a -> r -> a
runReader (ParsecT Text () (Reader FormatTable) Text
-> ()
-> String
-> Text
-> Reader FormatTable (Either ParseError Text)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT ParsecT Text () (Reader FormatTable) Text
parseFormatString () String
name Text
input) FormatTable
table of
    Left ParseError
e -> String -> Either String Text
forall a b. a -> Either a b
Left (ParseError -> String
forall b a. (Show a, IsString b) => a -> b
show ParseError
e)
    Right Text
t -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
t

-- | Format a 'Day' using the XML schema notation.
formatFullDate :: Maybe Day -> Maybe Text
formatFullDate :: Maybe Day -> Maybe Text
formatFullDate = String -> Maybe Day -> Maybe Text
formatDay String
"%Y-%m-%dT00:00:00Z"

-- | Format a 'Day' displaying just the year.
formatYear :: Maybe Day -> Maybe Text
formatYear :: Maybe Day -> Maybe Text
formatYear = String -> Maybe Day -> Maybe Text
formatDay String
"%Y"

formatDay :: String -> Maybe Day -> Maybe Text
formatDay :: String -> Maybe Day -> Maybe Text
formatDay String
fmt Maybe Day
d = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Day -> String) -> Day -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
fmt (Day -> Text) -> Maybe Day -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Day
d

parseFormatString :: Parser Text
parseFormatString :: ParsecT Text () (Reader FormatTable) Text
parseFormatString = ParsecT Text () (Reader FormatTable) (Text, Replacement)
-> ParsecT Text () (Reader FormatTable) ()
-> ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT Text () (Reader FormatTable) (Text, Replacement)
go ParsecT Text () (Reader FormatTable) ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
-> ([(Text, Replacement)]
    -> ParsecT Text () (Reader FormatTable) Text)
-> ParsecT Text () (Reader FormatTable) Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Text, Replacement)] -> ParsecT Text () (Reader FormatTable) Text
renderFormatString
  where
    go :: ParsecT Text () (Reader FormatTable) (Text, Replacement)
go = Parser (Text, Maybe Char)
findFormatCharacter Parser (Text, Maybe Char)
-> ((Text, Maybe Char)
    -> ParsecT Text () (Reader FormatTable) (Text, Replacement))
-> ParsecT Text () (Reader FormatTable) (Text, Replacement)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text, Maybe Char)
-> ParsecT Text () (Reader FormatTable) (Text, Replacement)
mkReplacement

-- | Render a format string syntax table as a 'Text' value.
renderFormatString :: [(Text, Replacement)] -> Parser Text
renderFormatString :: [(Text, Replacement)] -> ParsecT Text () (Reader FormatTable) Text
renderFormatString [(Text, Replacement)]
rs = do
  FormatTable
table <- ParsecT Text () (Reader FormatTable) FormatTable
forall r (m :: * -> *). MonadReader r m => m r
ask
  Text -> ParsecT Text () (Reader FormatTable) Text
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Replacement) -> Text) -> [(Text, Replacement)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FormatTable -> (Text, Replacement) -> Text
render FormatTable
table) [(Text, Replacement)]
rs)
  where
    escape :: Text -> Text
    escape :: Text -> Text
escape = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
translate (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString
    findChar :: FormatTable -> Char -> Text
    findChar :: FormatTable -> Char -> Text
findChar FormatTable
t Char
c = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Key FormatTable -> FormatTable -> Maybe (Val FormatTable)
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Char
Key FormatTable
c FormatTable
t)
    render :: FormatTable -> (Text, Replacement) -> Text
    render :: FormatTable -> (Text, Replacement) -> Text
render FormatTable
tbl (Text
txt, Replace Char
c) = Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escape (FormatTable -> Char -> Text
findChar FormatTable
tbl Char
c)
    render FormatTable
tbl (Text
txt, Condition [(Text, Replacement)]
c) = Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FormatTable -> [(Text, Replacement)] -> Text
renderCondition FormatTable
tbl [(Text, Replacement)]
c
    render FormatTable
_ (Text
txt, Replacement
EndOfInput) = Text
txt
    renderCondition :: FormatTable -> [(Text, Replacement)] -> Text
    renderCondition :: FormatTable -> [(Text, Replacement)] -> Text
renderCondition FormatTable
tbl [(Text, Replacement)]
conds =
      if ((Text, Replacement) -> Bool) -> [(Text, Replacement)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (FormatTable -> (Text, Replacement) -> Bool
checkCondition FormatTable
tbl) [(Text, Replacement)]
conds
        then [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Replacement) -> Text) -> [(Text, Replacement)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FormatTable -> (Text, Replacement) -> Text
render FormatTable
tbl) [(Text, Replacement)]
conds
        else Text
forall a. Monoid a => a
mempty
    checkCondition :: FormatTable -> (Text, Replacement) -> Bool
    checkCondition :: FormatTable -> (Text, Replacement) -> Bool
checkCondition FormatTable
tbl (Text
_, Replace Char
c) = Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Text) -> Maybe Text)
-> Maybe (Maybe Text) -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Key FormatTable -> FormatTable -> Maybe (Val FormatTable)
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Char
Key FormatTable
c FormatTable
tbl)
    checkCondition FormatTable
tbl (Text
_, Condition [(Text, Replacement)]
c) = ((Text, Replacement) -> Bool) -> [(Text, Replacement)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (FormatTable -> (Text, Replacement) -> Bool
checkCondition FormatTable
tbl) [(Text, Replacement)]
c
    checkCondition FormatTable
_ (Text
_, Replacement
EndOfInput) = Bool
True

-- | Location a format character preceded by a @'%'@ character.
-- Returns the text leading up to the format character and the
-- character itself.
findFormatCharacter :: Parser (Text, Maybe Char)
findFormatCharacter :: Parser (Text, Maybe Char)
findFormatCharacter = do
  Text
beforeText <- String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> ParsecT Text () (Reader FormatTable) String
-> ParsecT Text () (Reader FormatTable) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () (Reader FormatTable) Char
-> ParsecT Text () (Reader FormatTable) ()
-> ParsecT Text () (Reader FormatTable) String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT Text () (Reader FormatTable) Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (ParsecT Text () (Reader FormatTable) ()
-> ParsecT Text () (Reader FormatTable) ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT Text () (Reader FormatTable) ()
eofOrFormatChar)
  Maybe Char
formatChar <- ParsecT Text () (Reader FormatTable) (Maybe Char)
-> ParsecT Text () (Reader FormatTable) (Maybe Char)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT Text () (Reader FormatTable) (Maybe Char)
 -> ParsecT Text () (Reader FormatTable) (Maybe Char))
-> ParsecT Text () (Reader FormatTable) (Maybe Char)
-> ParsecT Text () (Reader FormatTable) (Maybe Char)
forall a b. (a -> b) -> a -> b
$ (Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char)
-> ParsecT Text () (Reader FormatTable) Char
-> ParsecT Text () (Reader FormatTable) (Maybe Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () (Reader FormatTable) Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar) ParsecT Text () (Reader FormatTable) (Maybe Char)
-> ParsecT Text () (Reader FormatTable) (Maybe Char)
-> ParsecT Text () (Reader FormatTable) (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Char -> ParsecT Text () (Reader FormatTable) (Maybe Char)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Char
forall a. Maybe a
Nothing
  (Text, Maybe Char) -> Parser (Text, Maybe Char)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
beforeText, Maybe Char
formatChar)
  where
    eofOrFormatChar :: Parser ()
    eofOrFormatChar :: ParsecT Text () (Reader FormatTable) ()
eofOrFormatChar = ParsecT Text () (Reader FormatTable) ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof ParsecT Text () (Reader FormatTable) ()
-> ParsecT Text () (Reader FormatTable) ()
-> ParsecT Text () (Reader FormatTable) ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Text () (Reader FormatTable) Char
-> ParsecT Text () (Reader FormatTable) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> ParsecT Text () (Reader FormatTable) Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'%')

-- | Translate the output from 'findFormatCharacter' into a syntax node.
mkReplacement :: (Text, Maybe Char) -> Parser (Text, Replacement)
mkReplacement :: (Text, Maybe Char)
-> ParsecT Text () (Reader FormatTable) (Text, Replacement)
mkReplacement (Text
beforeText, Maybe Char
formatChar) =
  case Maybe Char
formatChar of
    Maybe Char
Nothing -> (Text, Replacement)
-> ParsecT Text () (Reader FormatTable) (Text, Replacement)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
beforeText, Replacement
EndOfInput)
    Just Char
'{' -> (Text
beforeText,) (Replacement -> (Text, Replacement))
-> ParsecT Text () (Reader FormatTable) Replacement
-> ParsecT Text () (Reader FormatTable) (Text, Replacement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(Text, Replacement)] -> Replacement
Condition ([(Text, Replacement)] -> Replacement)
-> ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
-> ParsecT Text () (Reader FormatTable) Replacement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
parseConditional)
    Just Char
c -> (Text, Replacement)
-> ParsecT Text () (Reader FormatTable) (Text, Replacement)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
beforeText, Char -> Replacement
Replace Char
c)

-- | Parse a conditional section out of a format string.
parseConditional :: Parser [(Text, Replacement)]
parseConditional :: ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
parseConditional = do
  (Text
beforeText, Maybe Char
formatChar) <- Parser (Text, Maybe Char)
findFormatCharacter

  case Maybe Char
formatChar of
    -- Reached the end of the format string.
    Maybe Char
Nothing -> String
-> ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
forall s (m :: * -> *) t u a.
Stream s m t =>
String -> ParsecT s u m a
unexpected String
"end of format string, expected `%}'"
    -- Start another conditional.
    Just Char
'{' -> do
      [(Text, Replacement)]
other <- ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
parseConditional
      [(Text, Replacement)]
-> ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text
beforeText, [(Text, Replacement)] -> Replacement
Condition [(Text, Replacement)]
other)]

    -- End this conditional.
    Just Char
'}' -> [(Text, Replacement)]
-> ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text
beforeText, Replacement
EndOfInput)]
    -- Add this replacement to the list, fetch the next one.
    Just Char
c -> do
      [(Text, Replacement)]
next <- ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
parseConditional
      [(Text, Replacement)]
-> ParsecT Text () (Reader FormatTable) [(Text, Replacement)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Text
beforeText, Char -> Replacement
Replace Char
c) (Text, Replacement)
-> [(Text, Replacement)] -> [(Text, Replacement)]
forall a. a -> [a] -> [a]
: [(Text, Replacement)]
next)