{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Vimeta.Core.Format
( FormatTable
, fromFormatString
, formatYear
, formatFullDate
) where
import Control.Applicative hiding ((<|>))
import Control.Monad
import Control.Monad.Reader
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time (Day(..), formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import System.Process.Internals (translate)
import Text.Parsec
import Prelude
type FormatTable = Map Char (Maybe Text)
data Replacement = Replace Char
| Condition [(Text, Replacement)]
| EndOfInput
type Parser a = ParsecT Text () (Reader FormatTable) a
fromFormatString :: FormatTable
-> String
-> Text
-> Either String Text
fromFormatString table name input =
case runReader (runParserT parseFormatString () name input) table of
Left e -> Left (show e)
Right t -> Right t
formatFullDate :: Maybe Day -> Maybe Text
formatFullDate = formatDay "%Y-%m-%dT00:00:00Z"
formatYear :: Maybe Day -> Maybe Text
formatYear = formatDay "%Y"
formatDay :: String -> Maybe Day -> Maybe Text
formatDay fmt d = Text.pack . formatTime defaultTimeLocale fmt <$> d
parseFormatString :: Parser Text
parseFormatString = manyTill go eof >>= renderFormatString
where go = findFormatCharacter >>= mkReplacement
renderFormatString :: [(Text, Replacement)] -> Parser Text
renderFormatString rs = do table <- ask
return (Text.concat $ map (render table) rs)
where
escape :: Text -> Text
escape = Text.pack . translate . Text.unpack
findChar :: FormatTable -> Char -> Text
findChar t c = fromMaybe "" $ join (Map.lookup c t)
render :: FormatTable -> (Text, Replacement) -> Text
render tbl (txt, Replace c) = txt <> escape (findChar tbl c)
render tbl (txt, Condition c) = txt <> renderCondition tbl c
render _ (txt, EndOfInput) = txt
renderCondition :: FormatTable -> [(Text, Replacement)] -> Text
renderCondition tbl conds =
if all (checkCondition tbl) conds
then Text.concat $ map (render tbl) conds
else Text.empty
checkCondition :: FormatTable -> (Text, Replacement) -> Bool
checkCondition tbl (_, Replace c) = isJust (join $ Map.lookup c tbl)
checkCondition tbl (_, Condition c) = all (checkCondition tbl) c
checkCondition _ (_, EndOfInput) = True
findFormatCharacter :: Parser (Text, Maybe Char)
findFormatCharacter = do
beforeText <- Text.pack <$> manyTill anyChar (try eofOrFormatChar)
formatChar <- try $ (Just <$> anyChar) <|> return Nothing
return (beforeText, formatChar)
where
eofOrFormatChar :: Parser ()
eofOrFormatChar = eof <|> void (char '%')
mkReplacement :: (Text, Maybe Char) -> Parser (Text, Replacement)
mkReplacement (beforeText, formatChar) =
case formatChar of
Nothing -> return (beforeText, EndOfInput)
Just '{' -> (beforeText,) <$> (Condition <$> parseConditional)
Just c -> return (beforeText, Replace c)
parseConditional :: Parser [(Text, Replacement)]
parseConditional = do
(beforeText, formatChar) <- findFormatCharacter
case formatChar of
Nothing -> unexpected "end of format string, expected `%}'"
Just '{' -> do other <- parseConditional
return [(beforeText, Condition other)]
Just '}' -> return [(beforeText, EndOfInput)]
Just c -> do next <- parseConditional
return ((beforeText, Replace c) : next)