67 lines
2.1 KiB
Haskell
67 lines
2.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Blog.Wording (
|
|
Wording(..)
|
|
, build
|
|
, variables
|
|
) where
|
|
|
|
import Arguments (Arguments(..))
|
|
import Control.Monad (foldM)
|
|
import Data.Aeson (ToJSON(..))
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map (empty, fromList, keys, map, union)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text (pack)
|
|
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 Text)
|
|
|
|
variables :: Map String [Text]
|
|
variables = Map.fromList [
|
|
("allLink", [])
|
|
, ("allPage", ["tag"])
|
|
, ("commentsLink", [])
|
|
, ("commentsSection", [])
|
|
, ("dateFormat", [])
|
|
, ("latestLink", [])
|
|
, ("latestPage", ["tag"])
|
|
, ("metadata", ["author", "date", "tags"])
|
|
, ("rssLink", [])
|
|
, ("rssTitle", ["tag"])
|
|
, ("tagsList", [])
|
|
]
|
|
|
|
instance ToJSON Wording where
|
|
toJSON (Wording m) = toJSON m
|
|
toEncoding (Wording m) = toEncoding m
|
|
|
|
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
|
|
varEqual = choice (try . string <$> Map.keys variables) <* equal
|
|
line = (,) <$> varEqual <*> restOfLine
|
|
equal = many (char ' ') *> char '=' *> many (char ' ')
|
|
|
|
build :: Arguments -> IO Wording
|
|
build arguments = do
|
|
defaultWording <- getDataFileName "defaultWording.conf"
|
|
let wordingFiles = maybe id (:) (wording arguments) $ [defaultWording]
|
|
Wording <$> foldM addWording Map.empty wordingFiles
|