ConfigParser.hs

{-# LANGUAGE TupleSections #-}

module Boilerplate.ConfigParser (configParser, configCommentParser) where

import Boilerplate.Types
import Control.Applicative
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Text.Parser.Char
import Text.Parser.Combinators

-- parse the whole comment section to enhance locations in errors
configCommentParser :: CharParsing m => m Config
configCommentParser = (block <|> line) <* eof
  where
    block = between (string "{-" *> header) (try $ spaces *> string "-}") configParser
    line = string "--" *> header *> configParser <* spaces
    header = whitespace *> string "BOILERPLATE" *> whitespace
    whitespace = space *> spaces

configParser :: CharParsing m => m Config
configParser = try start <|> try end <|> config
  where
    start = ConfigStart <$ string "START"
    end = ConfigEnd <$ string "END"
    config = Config <$> conid <*> (whitespace *> rules) <*> option [] (try $ whitespace *> customs)
    whitespace = space <* spaces
    conid = (\c cs -> T.pack $ c : cs) <$> upper <*> many (noneOf " \t\n\r\f,")
    rules = sepBy1 conid (char ',' <* spaces)
    customs = sepEndBy1 custom whitespace -- consumes trailing whitespace
      where
        custom = (,) <$> (key <* spaces <* char '=' <* spaces) <*> customParser <?> "custom key/value"
        key = T.pack <$> some alphaNum <?> "custom key"

customParser :: CharParsing m => m Custom
customParser = (try nindexed <|> named <|> indexed <|> global) <?> "custom value"
  where
    nindexed = NamedIndexed <$> object array
    named = Named <$> object txt
    indexed = Indexed <$> array
    global = Global <$> txt

    object v = M.fromList <$> between (char '{' *> spaces) (spaces *> char '}') (sepBy kv comma)
      where kv = (,) <$> (symbol <* spaces <* char ':') <*> (spaces *> v)
    array = between (char '[' *> spaces) (spaces *> char ']') (sepBy txt comma)
    comma = try $ spaces *> char ',' <* spaces
    txt = quoted <|> symbol
      where quoted = T.pack <$> (many $ notChar '"') `surroundedBy` (char '"')
    symbol = T.pack <$> some alphaNum <?> "symbol"