191 lines
4.4 KiB
Haskell
191 lines
4.4 KiB
Haskell
{-# Language ConstraintKinds #-}
|
|
module Data.Config.Suckless.Parse.Megaparsec
|
|
( parseSyntax
|
|
, parseTop
|
|
, MegaParsec
|
|
, MegaContext
|
|
)
|
|
where
|
|
|
|
import Data.Config.Suckless.Syntax
|
|
|
|
import Control.Applicative()
|
|
|
|
import Data.Char (showLitChar)
|
|
import Data.Text qualified as Text
|
|
|
|
import Control.Monad
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char (hspace1,space1,char,letterChar,digitChar,eol)
|
|
import Text.Megaparsec.Char.Lexer qualified as L
|
|
import Text.Megaparsec.Char.Lexer ( signed )
|
|
import Data.String(IsString(..))
|
|
import GHC.Generics
|
|
import Data.Data
|
|
|
|
data MegaParsec =
|
|
MegaParsec
|
|
deriving (Data,Typeable,Generic)
|
|
|
|
newtype instance Context MegaParsec = MegaContext (Maybe Int)
|
|
|
|
instance IsContext MegaParsec where
|
|
noContext = MegaContext Nothing
|
|
|
|
type MegaContext = Context MegaParsec
|
|
|
|
type MegaConstraints c = ( c ~ MegaParsec, IsContext c )
|
|
|
|
type Parser r = Parsec () [Char] r
|
|
|
|
type ParseFail = ParseErrorBundle [Char] ()
|
|
|
|
sc :: Parser ()
|
|
sc = do
|
|
L.space space1 lineComment empty
|
|
where
|
|
lineComment = L.skipLineComment ";"
|
|
|
|
scTop :: Parser ()
|
|
scTop = do
|
|
L.space hspace1 lineComment empty
|
|
where
|
|
lineComment = L.skipLineComment ";"
|
|
|
|
dquot :: Parser Char
|
|
dquot = char '"'
|
|
|
|
-- FIXME: position!
|
|
stringLit :: forall c . MegaConstraints c
|
|
=> Parser () -> Parser (Syntax c)
|
|
|
|
stringLit sp = L.lexeme sp $ do
|
|
co <- MegaContext . Just <$> getOffset
|
|
Literal co . LitStr <$> str
|
|
where
|
|
str = do
|
|
s <- dquot >> manyTill L.charLiteral dquot
|
|
pure $ Text.pack s -- (mconcat [ showLitChar c "" | c <- s ])
|
|
|
|
-- FIXME: position!
|
|
intLit :: forall c . MegaConstraints c
|
|
=> Parser () -> Parser (Syntax c)
|
|
|
|
intLit sp = L.lexeme sp $ do
|
|
co <- MegaContext . Just <$> getOffset
|
|
Literal co . LitInt <$> choice [hex, oct, bin, dec, dec']
|
|
where
|
|
hex = L.symbol sc "0x" >> L.hexadecimal
|
|
oct = L.symbol sc "0o" >> L.octal
|
|
bin = L.symbol sc "0b" >> L.binary
|
|
dec = L.decimal
|
|
dec'= signed sc L.decimal
|
|
|
|
symbolChars :: [Char]
|
|
symbolChars = "!$%&|*+-/:<=>?@^_~#.'"
|
|
|
|
symbolChar :: Parser Char
|
|
symbolChar = oneOf symbolChars
|
|
|
|
-- FIXME: position!
|
|
symbol :: forall c . MegaConstraints c
|
|
=> Parser () -> Parser (Syntax c)
|
|
symbol sp = L.lexeme sp $ do
|
|
co <- MegaContext . Just <$> getOffset
|
|
h <- letterChar <|> symbolChar
|
|
t <- many (letterChar <|> digitChar <|> symbolChar)
|
|
case h:t of
|
|
"#t" -> pure $ Literal co (mkLit True)
|
|
"#f" -> pure $ Literal co (mkLit False)
|
|
other -> pure $ Symbol co (fromString other)
|
|
|
|
|
|
skipChar :: Char -> Parser ()
|
|
skipChar c = void (char c)
|
|
|
|
oParen :: Parser ()
|
|
oParen = skipChar '('
|
|
|
|
cParen :: Parser ()
|
|
cParen = skipChar ')'
|
|
|
|
oBrace :: Parser ()
|
|
oBrace = skipChar '{'
|
|
|
|
cBrace :: Parser ()
|
|
cBrace = skipChar '}'
|
|
|
|
oBracket :: Parser ()
|
|
oBracket= skipChar '['
|
|
|
|
cBracket :: Parser ()
|
|
cBracket = skipChar ']'
|
|
|
|
someEnclosedBy :: Parser ()
|
|
-> Parser a
|
|
-> Parser ()
|
|
-> Parser [a]
|
|
|
|
someEnclosedBy o i c = do
|
|
between o c (many (sc >> i)) -- <|> parseError (error (show ("WTF!", ctx))) -- (ParseError (ListParseError ctx))
|
|
|
|
list :: forall c . MegaConstraints c
|
|
=> Parser() -> Parser (Syntax c)
|
|
|
|
list sp = L.lexeme sp $ do
|
|
co <- MegaContext . Just <$> getOffset
|
|
List co <$> choice [ someEnclosedBy oParen (syntax sp) cParen
|
|
, someEnclosedBy oBrace (syntax sp) cBrace
|
|
, someEnclosedBy oBracket (syntax sp) cBracket
|
|
]
|
|
|
|
syntax :: forall c . MegaConstraints c
|
|
=> Parser () -> Parser (Syntax c)
|
|
syntax sp = choice [ symbol sp
|
|
, stringLit sp
|
|
, intLit sp
|
|
, list sp
|
|
]
|
|
|
|
merely :: Parser a -> Parser a
|
|
merely f = do
|
|
sc
|
|
r <- f
|
|
sc
|
|
eof
|
|
pure r
|
|
|
|
parseSyntax :: forall c . MegaConstraints c
|
|
=> String -> Either ParseFail (Syntax c)
|
|
|
|
parseSyntax = parse (merely (syntax sc)) "input"
|
|
|
|
top :: forall c . MegaConstraints c => Parser [Syntax c]
|
|
top = many $ do
|
|
t <- topStmt
|
|
sc
|
|
pure t
|
|
|
|
topTerm :: forall c . MegaConstraints c => Parser (Syntax c)
|
|
topTerm = do
|
|
L.lexeme sc $ do
|
|
co <- MegaContext . Just <$> getOffset
|
|
s0 <- symbol scTop
|
|
ss <- many (syntax scTop)
|
|
|
|
void eol <|> eof
|
|
pure $ List co (s0:ss)
|
|
|
|
topStmt :: forall c . MegaConstraints c => Parser (Syntax c)
|
|
topStmt = topTerm <|> syntax scTop
|
|
|
|
parseTop :: forall c . MegaConstraints c
|
|
=> String -> Either ParseFail [Syntax c]
|
|
|
|
parseTop = parse top "input"
|
|
|
|
deriving instance Data (Context MegaParsec)
|
|
|
|
|
|
|