nathanjgill.uk
this repo has no description
1{-# LANGUAGE OverloadedStrings #-}
2
3module Parser
4 ( Parser.parse,
5 )
6where
7
8import qualified Data.Text as T
9import Text.Megaparsec
10import Text.Megaparsec.Char
11import qualified Text.Megaparsec.Char.Lexer as L
12import Types
13
14newtype Error = Error T.Text deriving (Show, Eq, Ord)
15
16type Input = T.Text
17
18instance ShowErrorComponent Error where
19 showErrorComponent (Error e) = T.unpack e
20
21type NlsParser a = Parsec Error Input a
22
23sc :: NlsParser ()
24sc = L.space space1 lineComment empty
25
26lineComment :: NlsParser ()
27lineComment = L.skipLineComment (T.pack "#")
28
29lexeme :: NlsParser a -> NlsParser a
30lexeme = L.lexeme sc
31
32symbol :: T.Text -> NlsParser T.Text
33symbol = L.symbol sc
34
35parseSymbol :: NlsParser NlsAstValue
36parseSymbol = do
37 first <- letterChar <|> oneOf ("!$%&|*+-/:<=>?@^_~" :: String)
38 rest <- many (alphaNumChar <|> oneOf ("!$%&|*+-/:<=>?@^_~" :: String))
39 pure $ ASymbol (first : rest)
40
41parseQuote :: NlsParser NlsAstValue
42parseQuote = do
43 _ <- char '\''
44 v <- parseValue
45 pure $ AList [ASymbol "quote", v]
46
47parseEval :: NlsParser NlsAstValue
48parseEval = do
49 _ <- char '!'
50 v <- parseValue
51 pure $ AList [ASymbol "eval", v]
52
53parseNumber :: NlsParser NlsAstValue
54parseNumber = ANumber <$> lexeme L.decimal
55
56parseString :: NlsParser NlsAstValue
57parseString = AString <$> lexeme (char '"' >> manyTill L.charLiteral (char '"'))
58
59parseList :: NlsParser NlsAstValue
60parseList = AList <$> between (symbol "(") (symbol ")") (many parseValue)
61
62parseValue :: NlsParser NlsAstValue
63parseValue =
64 lexeme $
65 parseEval
66 <|> parseQuote
67 <|> parseNumber
68 <|> parseString
69 <|> parseSymbol
70 <|> parseList
71
72parseProgram :: NlsParser [NlsAstValue]
73parseProgram = between sc eof (many parseValue)
74
75parse :: Input -> Either T.Text [NlsAstValue]
76parse input =
77 case runParser parseProgram "" input of
78 Left err -> Left $ T.pack $ errorBundlePretty err
79 Right val -> Right val