74 lines
1.4 KiB
Haskell
74 lines
1.4 KiB
Haskell
module Parser where
|
|
|
|
import Control.Applicative (liftA2)
|
|
import Data.Char
|
|
import Data.Void
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char
|
|
|
|
data AST
|
|
= Call String [AST]
|
|
| Seq [AST]
|
|
| List [AST] (Maybe AST)
|
|
| Literal String
|
|
deriving (Show)
|
|
|
|
specialOp = (`elem` ",;|")
|
|
|
|
specialChar = (`elem` "()[]")
|
|
|
|
specialName = (`elem` "_")
|
|
|
|
specialUnused = (`elem` "\'%")
|
|
|
|
type Lexer = Parsec Void String
|
|
|
|
data Lexeme
|
|
= Blank String
|
|
| Tok String
|
|
| QTok String String -- unquoted quoted
|
|
| Cmt String
|
|
deriving (Show)
|
|
|
|
blank :: Lexer Lexeme
|
|
blank = Blank <$> some (satisfy isSpace)
|
|
|
|
tok :: Lexer Lexeme
|
|
tok =
|
|
Tok <$>
|
|
choice
|
|
[ pure <$> satisfy specialOp
|
|
, pure <$> satisfy specialChar
|
|
, some $
|
|
satisfy $ \x ->
|
|
all
|
|
($ x)
|
|
[ not . specialOp
|
|
, not . specialChar
|
|
, not . specialUnused
|
|
, not . specialName
|
|
, liftA2 (||) isSymbol isPunctuation
|
|
]
|
|
, (:) <$> satisfy (\x -> any ($ x) [specialName, isAlpha]) <*>
|
|
many (satisfy $ \x -> any ($ x) [specialName, isAlphaNum, isMark])
|
|
]
|
|
|
|
qtok :: Lexer Lexeme
|
|
qtok = do
|
|
x <- string "'"
|
|
y <- many $ satisfy (/= '\'')
|
|
z <- string "'"
|
|
return $ QTok y (x ++ y ++ z)
|
|
|
|
cmt :: Lexer Lexeme
|
|
cmt =
|
|
Cmt . concat <$>
|
|
sequence
|
|
[string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
|
|
|
|
lexeme :: Lexer Lexeme
|
|
lexeme = choice [blank, tok, qtok, cmt]
|
|
|
|
lex :: Lexer [Lexeme]
|
|
lex = many lexeme <* eof
|