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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
module Hint.Parser where
import Control.Applicative (Alternative (..))
import Control.Monad (void)
import Data.Either (fromRight)
import qualified Data.Text as T
import Hint.Data
import Hint.Lexer (Input, Token (..), TokenKind (..),
runProd)
data ParseError
= UnexpectedToken [TokenKind]
| NoParse
deriving (Show, Eq)
data BinOp
= Add
| Mult
deriving (Show, Eq)
newtype Parser a = Parser
{ unParser :: [Token] -> Either ParseError (a, [Token]) }
instance Functor Parser where
fmap f (Parser p) = Parser $ \ts -> do
(a, rest) <- p ts
pure (f a, rest)
instance Applicative Parser where
pure a = Parser $ \ts -> Right (a, ts)
(<*>) (Parser pf) (Parser px) = Parser $ \ts -> do
(f, ts') <- pf ts
(x, ts'') <- px ts'
pure (f x, ts'')
instance Monad Parser where
return = pure
(>>=) (Parser p) f = Parser $ \ts -> do
(x, ts') <- p ts
unParser (f x) ts'
instance Alternative Parser where
empty = Parser $ const $ Left NoParse
(<|>) (Parser p) (Parser q) = Parser $ \ts ->
case p ts of
Right a -> Right a
Left _ -> q ts
runParser :: Parser a -> Input -> Either ParseError (a, [Token])
runParser p = unParser p . fromRight [] . runProd
token :: TokenKind -> Parser Token
token t = sat (== t)
sat :: (TokenKind -> Bool) -> Parser Token
sat p = Parser parse
where
parse [] = Left $ UnexpectedToken [TEof]
parse (t@(Token kind _) : ts)
| p kind = Right (t, ts)
| otherwise = Left $ UnexpectedToken [kind]
pStr :: Parser Literal
pStr = String . T.pack <$> Parser parseString
where
parseString (Token (TString s) _ : ts) = pure (s, ts)
parseString _ = Left NoParse
pBool :: Parser Literal
pBool = (Boolean False <$ sat (== KeywordFalse)) <|> (Boolean True <$ sat (== KeywordTrue))
pNumeric :: Parser Literal
pNumeric = Int <$> Parser p
where
p (Token (TInt i) _ : ts) = pure (i, ts)
p _ = Left NoParse
parseWord :: String -> Parser Token
parseWord name = Parser parse
where
parse [] = Left NoParse
parse (t@(Token (TIdent n) _) : ts)
| name == n = Right (t, ts)
parse _ = Left NoParse
parseLiteral :: Parser Expr
parseLiteral = Literal <$> (pStr <|> pBool <|> pNumeric)
parseIdentifier :: Parser Identifier
parseIdentifier = Parser p
where
p (Token (TIdent s) _ : ts) = pure (Identifier $ T.pack s, ts)
p _ = Left NoParse
parseBinding :: Parser Expr
parseBinding = do
void $ token KeywordLet
name <- parseIdentifier
void $ token TEquals
value <- expr
void $ token KeywordIn
body <- expr
pure $ Bind name value body
parseIf :: Parser Expr
parseIf = do
void $ token KeywordIf
cond <- expr
void $ token KeywordThen
a <- expr
void $ token KeywordElse
b <- expr
pure $ If cond a b
expr :: Parser Expr
expr = parseLiteral
<|> parseIf
<|> parseBinding
<|> Ident <$> parseIdentifier
|
