Parser.hs

{-# LANGUAGE OverloadedStrings #-}

module Data.Scfg.Parser (parseConfig) where

import Control.Monad (void)
import Data.Char (isControl)
import Data.Functor (($>))
import Data.List.NonEmpty (head)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Scfg.Types
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import Text.Megaparsec hiding (ParseError)
import Text.Megaparsec.Char
import Prelude hiding (head)

type Parser = Parsec Void Text

parseConfig :: Text -> Either ParseError Config
parseConfig input = case parse config "" input of
  Left bundle ->
    let firstError = head (bundleErrors bundle)
        offset = errorOffset firstError
        (_, state) = reachOffset offset (bundlePosState bundle)
        SourcePos _ l c = pstateSourcePos state
     in Left
          ParseError
            { errorLine = unPos l
            , errorColumn = unPos c
            , errorMessage = T.pack (errorBundlePretty bundle)
            }
  Right c -> Right c

config :: Parser Config
config = catMaybes <$> many line <* eof

line :: Parser (Maybe Directive)
line = hspace *> ((newline $> Nothing) <|> (comment $> Nothing) <|> (Just <$> directive))

comment :: Parser ()
comment = (char '#' *> takeWhileP Nothing isVChar *> newline) $> ()

directive :: Parser Directive
directive = do
  n <- word
  params <- many (try (hspace1 *> word))
  children <- optional (try (hspace1 *> block))
  _ <- hspace *> (void newline <|> eof)
  pure (Directive n params (fromMaybe [] children))

block :: Parser [Directive]
block = do
  _ <- char '{'
  _ <- hspace *> newline
  ds <- catMaybes <$> many (try line)
  _ <- hspace *> char '}'
  pure ds

word :: Parser Text
word = dquoteWord <|> squoteWord <|> atom

atom :: Parser Text
atom = T.concat <$> some (escPair <|> takeWhile1P (Just "character") isAtomChar)

dquoteWord :: Parser Text
dquoteWord = char '"' *> (T.concat <$> many (escPair <|> takeWhile1P (Just "character") isDqChar)) <* char '"'

squoteWord :: Parser Text
squoteWord = char '\'' *> (takeWhile1P (Just "character") isSqChar <|> pure "") <* char '\''

escPair :: Parser Text
escPair = T.singleton <$> (char '\\' *> satisfy isVChar)

isVChar :: Char -> Bool
isVChar c = c == '\t' || (not (isControl c) && c /= '\n')

isAtomChar :: Char -> Bool
isAtomChar c = not (isControl c) && c /= ' ' && c /= '\n' && c /= '{' && c /= '}' && c /= '"' && c /= '\\' && c /= '\''

isDqChar :: Char -> Bool
isDqChar c = (c == '\t' || not (isControl c)) && c /= '"' && c /= '\\' && c /= '\n'

isSqChar :: Char -> Bool
isSqChar c = (c == '\t' || not (isControl c)) && c /= '\'' && c /= '\n'