module Text.SmallCaps.ConfigParser where
import Prelude hiding ( lex, takeWhile )
import Data.Char ( isAlpha, isAlphaNum, isPunctuation )
import Data.Text hiding ( replace, takeWhile )
import Data.Map ( Map )
import qualified Data.Map as Map ( lookup )
import Data.Attoparsec.Text ( Parser, parseOnly, char, takeWhile1, asciiCI, skipSpace, isEndOfLine )
import Data.Attoparsec.Combinator ( many' )
import Control.Monad ( mplus, msum )
import Text.SmallCaps.LaTeX ( LaTeXElement, name )
import Text.SmallCaps.Config ( ParserState (..), Config (..), PatternReplace (..), defaultReplaceTemplate, defaultReplaceTemplate', blacklist, whitelist )
import Text.SmallCaps.TeXParser ( macroBegin, macroName )
reconfigure :: ParserState -> Text -> Either (Text, Config) Config
reconfigure state = either (const (Right (config state))) id . parseOnly (reconfiguration state)
reconfiguration :: ParserState -> Parser (Either (Text, Config) Config)
reconfiguration state = preamble >> msum
[ fmap Right $ profileMain (profile state)
, fmap Left $ storeMain conf
, fmap Right $ periodMain conf
, fmap Right $ replaceMain conf
, fmap Right $ searchMain conf
, fmap Right $ isolateMain conf
, fmap Right $ skipMain conf
, fmap Right $ unskipMain conf
, fmap Right $ eosMain conf
, fmap Right $ exceptMain conf
] where conf = config state
lex :: Parser a -> Parser a
lex p = skipSpace >> p
preamble :: Parser Text
preamble = char '%' >> lex (asciiCI (pack "smallcaps"))
profileMain :: Map Text Config -> Parser Config
profileMain ps = profilePre >> profileName ps
profilePre :: Parser Text
profilePre = lex (asciiCI (pack "reset") `mplus` asciiCI (pack "restore")) >> lex (asciiCI (pack "profile"))
profileName :: Map Text Config -> Parser Config
profileName ps = maybe (fail "profile not found") return . flip Map.lookup ps =<< lex (takeWhile1 isAlphaNum)
storeMain :: Config -> Parser (Text, Config)
storeMain = (storePre >>) . storeName
storePre :: Parser Text
storePre = lex (asciiCI (pack "store")) >> lex (asciiCI (pack "profile"))
storeName :: Config -> Parser (Text, Config)
storeName conf = fmap (flip (,) conf) (lex $ takeWhile1 isAlphaNum)
periodMain :: Config -> Parser Config
periodMain = (periodPre >>) . periodSigns
periodPre :: Parser Text
periodPre = lex (asciiCI (pack "periods")) >> lex (asciiCI (pack "are"))
periodSigns :: Config -> Parser Config
periodSigns conf = lex (takeWhile1 isPunctuation) >>= \s -> return $ conf { periodChars = unpack s }
replaceMain :: Config -> Parser Config
replaceMain conf = replacePre >> msum
[ replaceStyleNoarg
, replaceStyleInarg
] >>= replaceMacro conf
replacePre :: Parser Text
replacePre = lex $ asciiCI (pack "substitution")
data Style = NoArg | InArg deriving (Show, Eq)
replaceStyleNoarg :: Parser Style
replaceStyleNoarg = lex (asciiCI (pack "in")) >> lex (asciiCI (pack "block")) >> lex (asciiCI (pack "with")) >> return NoArg
replaceStyleInarg :: Parser Style
replaceStyleInarg = lex (asciiCI (pack "as")) >> lex (asciiCI (pack "argument")) >> lex (asciiCI (pack "of")) >> return InArg
replaceMacro :: Config -> Style -> Parser Config
replaceMacro conf style
| style == NoArg = fun defaultReplaceTemplate
| otherwise = fun defaultReplaceTemplate'
where fun gun = lex $ macroBegin >> macroName >>= \macro -> return $ conf { replace = gun (cons '\\' macro) }
searchMain :: Config -> Parser Config
searchMain = (searchPre >>) . searchList
searchPre :: Parser Text
searchPre = lex $ asciiCI (pack "search")
searchList :: Config -> Parser Config
searchList conf = list' (search conf) >>= \fun -> return $ conf { search = fun }
isolateMain :: Config -> Parser Config
isolateMain = (isolatePre >>) . isolateList
isolatePre :: Parser Text
isolatePre = lex $ asciiCI (pack "isolate")
isolateList :: Config -> Parser Config
isolateList conf = iList (isolate conf) >>= \fun -> return $ conf { isolate = fun }
skipMain :: Config -> Parser Config
skipMain = (skipPre >>) . skipList
skipPre :: Parser Text
skipPre = lex $ asciiCI (pack "skip")
skipList :: Config -> Parser Config
skipList conf = list (skip conf) >>= \fun -> return $ conf { skip = fun }
unskipMain :: Config -> Parser Config
unskipMain = (unskipPre >>) . unskipList
unskipPre :: Parser Text
unskipPre = lex $ asciiCI (pack "unskip")
unskipList :: Config -> Parser Config
unskipList conf = list (unskip conf) >>= \fun -> return $ conf { unskip = fun }
eosMain :: Config -> Parser Config
eosMain = (eosPre >>) . eosList
eosPre :: Parser Text
eosPre = lex $ asciiCI (pack "eos")
eosList :: Config -> Parser Config
eosList conf = list (eos conf) >>= \fun -> return $ conf { eos = fun }
exceptMain :: Config -> Parser Config
exceptMain = (exceptPre >>) . exceptTuple
exceptPre :: Parser Text
exceptPre = lex (asciiCI (pack "except"))
exceptTuple :: Config -> Parser Config
exceptTuple conf = do
word <- lex (takeWhile1 isAlphaNum)
repl <- (lex (asciiCI (pack "put")) >> lex (takeWhile1 (not . isEndOfLine))) `mplus` return word
return $ conf { exceptions = PatternReplace
{ pattern = word
, replacement = repl
} : exceptions conf }
list :: (LaTeXElement -> Bool) -> Parser (LaTeXElement -> Bool)
list fun = msum [listBlack fun, listWhite fun, listConstAll, listConstNone]
list' :: (LaTeXElement -> Bool) -> Parser (LaTeXElement -> Bool)
list' fun = msum [listBlack fun, listWhite fun, listConstAll', listConstNone']
listBlack :: (LaTeXElement -> Bool) -> Parser (LaTeXElement -> Bool)
listBlack fun = lex (char '-') >> listItems >>= \xs -> return (\x -> not (name x `elem` xs) && fun x)
listWhite :: (LaTeXElement -> Bool) -> Parser (LaTeXElement -> Bool)
listWhite fun = lex $ char '+' >> listItems >>= \xs -> return (\x -> name x `elem` xs || fun x)
listConstAll :: Parser (a -> Bool)
listConstAll = lex (char '*') >> return (const True)
listConstAll' :: Parser (LaTeXElement -> Bool)
listConstAll' = lex (char '*') >> return (blacklist [])
listConstNone :: Parser (a -> Bool)
listConstNone = lex (char '/') >> return (const False)
listConstNone' :: Parser (LaTeXElement -> Bool)
listConstNone' = lex (char '/') >> return (whitelist [])
iList :: (LaTeXElement -> Maybe Text) -> Parser (LaTeXElement -> Maybe Text)
iList fun = msum [iListBlack fun, iListWhite fun, iListConstAll, iListConstNone]
iListBlack :: (LaTeXElement -> Maybe Text) -> Parser (LaTeXElement -> Maybe Text)
iListBlack fun = do
_ <- lex $ char '-'
xs <- listItems
return $ \x -> if x `isElement` xs
then Nothing
else fun x
iListWhite :: (LaTeXElement -> Maybe Text) -> Parser (LaTeXElement -> Maybe Text)
iListWhite fun = do
c <- lex $ takeWhile1 isAlphaNum `mplus` return (pack "default")
_ <- lex $ char '+'
xs <- listItems
return $ \x -> if x `isElement` xs
then Just c
else fun x
iListConstAll :: Parser (LaTeXElement -> Maybe Text)
iListConstAll = do
c <- lex $ takeWhile1 isAlphaNum `mplus` return (pack "default")
_ <- lex $ char '*'
return $ const (Just c)
iListConstNone :: Parser (LaTeXElement -> Maybe Text)
iListConstNone = do
_ <- lex $ char '/'
return $ const Nothing
listItems :: Parser [Text]
listItems = do
x <- listItem
xs <- many' (listItemSeparator >> listItem)
return (x:xs)
listItem :: Parser Text
listItem = listItemMacro `mplus` listItemEnvironment
listItemMacro :: Parser Text
listItemMacro = lex (macroBegin >> fmap (cons '\\') macroName)
listItemEnvironment :: Parser Text
listItemEnvironment = lex (takeWhile1 isAlpha)
listItemSeparator :: Parser Char
listItemSeparator = lex $ char ','
isElement :: LaTeXElement -> [Text] -> Bool
isElement = elem . name