101 lines
3.6 KiB
Haskell
101 lines
3.6 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Blog.Wording (
|
|
Wording(..)
|
|
, build
|
|
) where
|
|
|
|
import Arguments (Arguments(..))
|
|
import Control.Monad (foldM)
|
|
import Data.Aeson (ToJSON(..), (.=), object, pairs)
|
|
import Data.List (intercalate)
|
|
import Data.Map (Map, (!))
|
|
import qualified Data.Map as Map (empty, fromList, map, union)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text (pack, unpack)
|
|
import Data.Text.Template (Template, renderA, showTemplate, templateSafe)
|
|
import Paths_hablo (getDataFileName)
|
|
import Text.ParserCombinators.Parsec (
|
|
Parser
|
|
, (<|>)
|
|
, char, choice, endBy, many, many1, noneOf, parse, string, try
|
|
)
|
|
import System.Exit (die)
|
|
|
|
data Wording = Wording {
|
|
allLink :: Text
|
|
, allPage :: Text
|
|
, allTaggedPage :: Template
|
|
, commentsSection :: Text
|
|
, latestLink :: Text
|
|
, latestPage :: Text
|
|
, latestTaggedPage :: Template
|
|
, tagsList :: Text
|
|
}
|
|
|
|
keys :: [String]
|
|
keys = [
|
|
"allLink", "allPage", "allTaggedPage", "commentsSection"
|
|
, "latestLink", "latestPage", "latestTaggedPage", "tagsList"
|
|
]
|
|
|
|
values :: [Wording -> Text]
|
|
values = [
|
|
allLink, allPage, showTemplate . allTaggedPage, commentsSection
|
|
, latestLink, latestPage, showTemplate . latestTaggedPage, tagsList
|
|
]
|
|
|
|
texts :: Wording -> [Text]
|
|
texts wording = ($ wording) <$> values
|
|
|
|
instance ToJSON Wording where
|
|
toJSON = object . zipWith (.=) (Text.pack <$> keys) . texts
|
|
toEncoding = pairs . foldl (<>) mempty . zipWith (.=) (Text.pack <$> keys) . texts
|
|
|
|
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 eol *> line `endBy` (many1 eol))
|
|
where
|
|
line = (,) <$> (choice (try . string <$> keys) <* equal) <*> many (noneOf "\r\n")
|
|
equal = many (char ' ') *> char '=' *> many (char ' ')
|
|
eol = try (string "\r\n") <|> string "\r" <|> string "\n"
|
|
|
|
checkTemplateWith :: [Text] -> String -> Map String Text -> IO Template
|
|
checkTemplateWith variables key wording =
|
|
let templateText = wording ! key in
|
|
let testEnvironment = flip lookup [(s, "") | s <- variables] 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 =
|
|
" (available variables: " ++ intercalate ", " (Text.unpack <$> variables) ++ ")"
|
|
syntaxError row col =
|
|
"Syntax error in template for variable " ++ key ++ "at l." ++ row ++ ", c." ++ col
|
|
badTemplate = "Invalid template for variable " ++ key ++ availableVariables
|
|
|
|
build :: Arguments -> IO Wording
|
|
build arguments = do
|
|
defaultWording <- getDataFileName "defaultWording.conf"
|
|
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
|
|
wording <- foldM addWording Map.empty wordingFiles
|
|
allTaggedPage <- checkTemplateWith ["tag"] "allTaggedPage" wording
|
|
latestTaggedPage <- checkTemplateWith ["tag"] "latestTaggedPage" wording
|
|
return Wording {
|
|
allLink = wording ! "allLink"
|
|
, allPage = wording ! "allPage"
|
|
, allTaggedPage
|
|
, commentsSection = wording ! "commentsSection"
|
|
, latestLink = wording ! "latestLink"
|
|
, latestPage = wording ! "latestPage"
|
|
, latestTaggedPage
|
|
, tagsList = wording ! "tagsList"
|
|
}
|