1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
|
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
|
