haskell-scfg

 1{-# LANGUAGE OverloadedStrings #-}
 2
 3module Data.Scfg.Parser (parseConfig) where
 4
 5import Control.Monad (void)
 6import Data.Char (isControl)
 7import Data.Functor (($>))
 8import Data.List.NonEmpty (head)
 9import Data.Maybe (catMaybes, fromMaybe)
10import Data.Scfg.Types
11import Data.Text (Text)
12import qualified Data.Text as T
13import Data.Void (Void)
14import Text.Megaparsec hiding (ParseError)
15import Text.Megaparsec.Char
16import Prelude hiding (head)
17
18type Parser = Parsec Void Text
19
20parseConfig :: Text -> Either ParseError Config
21parseConfig input = case parse config "" input of
22  Left bundle ->
23    let firstError = head (bundleErrors bundle)
24        offset = errorOffset firstError
25        (_, state) = reachOffset offset (bundlePosState bundle)
26        SourcePos _ l c = pstateSourcePos state
27     in Left
28          ParseError
29            { errorLine = unPos l
30            , errorColumn = unPos c
31            , errorMessage = T.pack (errorBundlePretty bundle)
32            }
33  Right c -> Right c
34
35config :: Parser Config
36config = catMaybes <$> many line <* eof
37
38line :: Parser (Maybe Directive)
39line = hspace *> ((newline $> Nothing) <|> (comment $> Nothing) <|> (Just <$> directive))
40
41comment :: Parser ()
42comment = (char '#' *> takeWhileP Nothing isVChar *> newline) $> ()
43
44directive :: Parser Directive
45directive = do
46  n <- word
47  params <- many (try (hspace1 *> word))
48  children <- optional (try (hspace1 *> block))
49  _ <- hspace *> (void newline <|> eof)
50  pure (Directive n params (fromMaybe [] children))
51
52block :: Parser [Directive]
53block = do
54  _ <- char '{'
55  _ <- hspace *> newline
56  ds <- catMaybes <$> many (try line)
57  _ <- hspace *> char '}'
58  pure ds
59
60word :: Parser Text
61word = dquoteWord <|> squoteWord <|> atom
62
63atom :: Parser Text
64atom = T.concat <$> some (escPair <|> takeWhile1P (Just "character") isAtomChar)
65
66dquoteWord :: Parser Text
67dquoteWord = char '"' *> (T.concat <$> many (escPair <|> takeWhile1P (Just "character") isDqChar)) <* char '"'
68
69squoteWord :: Parser Text
70squoteWord = char '\'' *> (takeWhile1P (Just "character") isSqChar <|> pure "") <* char '\''
71
72escPair :: Parser Text
73escPair = T.singleton <$> (char '\\' *> satisfy isVChar)
74
75isVChar :: Char -> Bool
76isVChar c = c == '\t' || (not (isControl c) && c /= '\n')
77
78isAtomChar :: Char -> Bool
79isAtomChar c = not (isControl c) && c /= ' ' && c /= '\n' && c /= '{' && c /= '}' && c /= '"' && c /= '\\' && c /= '\''
80
81isDqChar :: Char -> Bool
82isDqChar c = (c == '\t' || not (isControl c)) && c /= '"' && c /= '\\' && c /= '\n'
83
84isSqChar :: Char -> Bool
85isSqChar c = (c == '\t' || not (isControl c)) && c /= '\'' && c /= '\n'