148 lines
3.4 KiB
Haskell
148 lines
3.4 KiB
Haskell
module Data.Config.Suckless.Parse.Megaparsec
|
|
where
|
|
|
|
import Data.Config.Suckless.Syntax
|
|
|
|
import Control.Applicative()
|
|
|
|
import Data.Char (showLitChar)
|
|
import Data.Text qualified as Text
|
|
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char (space1,char,letterChar,digitChar)
|
|
import Text.Megaparsec.Char.Lexer qualified as L
|
|
import Text.Megaparsec.Char.Lexer ( signed )
|
|
import Data.String(IsString(..))
|
|
|
|
import Debug.Trace
|
|
|
|
type Parser r = Parsec () [Char] r
|
|
|
|
type ParseFail = ParseErrorBundle [Char] ()
|
|
|
|
sc :: Parser ()
|
|
sc = do
|
|
L.space space1 lineComment empty
|
|
where
|
|
lineComment = L.skipLineComment ";"
|
|
|
|
dquot :: Parser Char
|
|
dquot = char '"'
|
|
|
|
-- FIXME: position!
|
|
stringLit :: Monoid (Context c) => Parser (Syntax c)
|
|
stringLit = L.lexeme sc $
|
|
Literal mempty . LitStr <$> str
|
|
where
|
|
str = do
|
|
s <- dquot >> manyTill L.charLiteral dquot
|
|
pure $ Text.pack (mconcat [ showLitChar c "" | c <- s ])
|
|
|
|
{-
|
|
|
|
-- FIXME: position!
|
|
intLit :: Parser Syntax
|
|
intLit = L.lexeme sc $
|
|
Literal . 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 :: Parser Syntax
|
|
symbol = L.lexeme sc $ do
|
|
co <- Context . Just <$> getOffset
|
|
h <- letterChar <|> symbolChar
|
|
t <- many (letterChar <|> digitChar <|> symbolChar)
|
|
case Symbol (fromString (h:t)) of
|
|
SymbolVal "#t" -> pure $ Literal (mkLit True)
|
|
SymbolVal "#f" -> pure $ Literal (mkLit False)
|
|
SymbolVal other -> pure (Symbol_ co 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 :: Parser Syntax
|
|
list = L.lexeme sc $ do
|
|
co <- Context . Just <$> getOffset
|
|
-- traceShowM ("List", co)
|
|
List_ co <$> choice [ someEnclosedBy oParen syntax cParen
|
|
, someEnclosedBy oBrace syntax cBrace
|
|
, someEnclosedBy oBracket syntax cBracket
|
|
]
|
|
|
|
syntax :: Parser Syntax
|
|
syntax = choice [ symbol
|
|
, stringLit
|
|
, intLit
|
|
, list
|
|
]
|
|
|
|
-- top :: Parser (AST (Core S))
|
|
-- top = sc >> many syntaxWithPos >>= toAST
|
|
-- where
|
|
-- -- FIXME: push real position here
|
|
-- syntaxWithPos = do
|
|
-- pos <- getOffset
|
|
-- node <- (pos,) <$> syntax
|
|
-- pure node
|
|
|
|
-- toAST xs = go xs
|
|
|
|
-- go :: [(Int, Syntax)] -> Parser (AST (Core S))
|
|
-- go ( (p, syn) : rest ) = do
|
|
-- let c = Context (Just p)
|
|
-- mkExpr c . Seq syn <$> go rest
|
|
|
|
-- go [] = pure $ mkLeaf0 ()
|
|
|
|
-- merely :: Parser a -> Parser a
|
|
-- merely f = do
|
|
-- sc
|
|
-- r <- f
|
|
-- sc
|
|
-- eof
|
|
-- pure r
|
|
|
|
-- parseSyntax :: String -> Either ParseFail Syntax
|
|
-- parseSyntax = parse (merely syntax) "input"
|
|
|
|
-- parseTop :: String -> Either ParseFail (AST (Core S))
|
|
-- parseTop = parse top "input"
|
|
-}
|