95 lines
3.4 KiB
Haskell
95 lines
3.4 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Blog.Wording (
|
|
Wording(..)
|
|
, build
|
|
, render
|
|
) where
|
|
|
|
import Arguments (Arguments(..))
|
|
import Control.Monad (foldM)
|
|
import Data.Aeson (ToJSON(..))
|
|
import Data.List (intercalate)
|
|
import Data.Map (Map, (!))
|
|
import qualified Data.Map as Map (empty, fromList, insert, keys, map, union)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text (pack, unpack)
|
|
import Data.Text.Lazy (toStrict)
|
|
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
|
|
import qualified Data.Text.Template as Template (render)
|
|
import Paths_hablo (getDataFileName)
|
|
import Text.ParserCombinators.Parsec (
|
|
Parser
|
|
, (<|>)
|
|
, char, choice, endBy, eof, many, many1, noneOf, optional, parse, string, try
|
|
)
|
|
import System.Exit (die)
|
|
|
|
newtype Wording = Wording (Map String Template)
|
|
|
|
variables :: Map String [Text]
|
|
variables = Map.fromList [
|
|
("allLink", [])
|
|
, ("allPage", [])
|
|
, ("allTaggedPage", ["tag"])
|
|
, ("commentsLink", [])
|
|
, ("commentsSection", [])
|
|
, ("dateFormat", [])
|
|
, ("latestLink", [])
|
|
, ("latestPage", [])
|
|
, ("latestTaggedPage", ["tag"])
|
|
, ("metadata", ["author", "date", "tags"])
|
|
, ("tagsList", [])
|
|
]
|
|
|
|
|
|
instance ToJSON Wording where
|
|
toJSON (Wording m) = toJSON (showTemplate <$> m)
|
|
toEncoding (Wording m) = toEncoding (showTemplate <$> m)
|
|
|
|
render :: String -> [(Text, Text)] -> Wording -> Text
|
|
render key env (Wording wMap) =
|
|
toStrict $ Template.render (wMap ! key) (Map.fromList env !)
|
|
|
|
addWording :: Map String Text -> FilePath -> IO (Map String Text)
|
|
addWording currentWording wordingFile = do
|
|
parsed <- parse wordingP wordingFile <$> readFile wordingFile
|
|
case parsed of
|
|
Left errorMessage -> die $ show errorMessage
|
|
Right newWording -> return $ Map.union currentWording newWording
|
|
|
|
wordingP :: Parser (Map String Text)
|
|
wordingP = Map.map Text.pack . Map.fromList <$>
|
|
(many skip *> line `endBy` (many1 skip) <* eof)
|
|
where
|
|
restOfLine = many $ noneOf "\r\n"
|
|
eol = try (string "\r\n") <|> string "\r" <|> string "\n"
|
|
skip = optional (char '#' *> restOfLine) *> eol
|
|
line = (,) <$> (choice (try . string <$> Map.keys variables) <* equal) <*> restOfLine
|
|
equal = many (char ' ') *> char '=' *> many (char ' ')
|
|
|
|
makeTemplate :: String -> Map String Text -> IO Template
|
|
makeTemplate key wording =
|
|
let templateText = wording ! key in
|
|
let testEnvironment = flip lookup [(s, "") | s <- availableVariables] in
|
|
case templateSafe templateText of
|
|
Left (row, col) -> die $ syntaxError (show row) (show col)
|
|
Right template ->
|
|
maybe (die badTemplate) (return . const template) (renderA template testEnvironment)
|
|
where
|
|
availableVariables = variables ! key
|
|
variablesMessage =
|
|
" (available variables: " ++ intercalate ", " (Text.unpack <$> availableVariables) ++ ")"
|
|
syntaxError row col =
|
|
"Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
|
|
badTemplate = "Invalid template for variable " ++ key ++ variablesMessage
|
|
|
|
build :: Arguments -> IO Wording
|
|
build arguments = do
|
|
defaultWording <- getDataFileName "defaultWording.conf"
|
|
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
|
|
wordindMap <- foldM addWording Map.empty wordingFiles
|
|
Wording <$> foldM (
|
|
\templated key -> flip (Map.insert key) templated <$> makeTemplate key wordindMap
|
|
) Map.empty (Map.keys variables)
|