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
|
module Hint.Parser where
import Control.Applicative (Alternative (..), many)
import Data.Either (fromRight)
import Hint.Lexer (Input, Token (..), TokenKind (..),
runProd)
data ParseError
= UnexpectedToken [TokenKind]
| NoParse
deriving (Show, Eq)
data Value
= VInt Int
| VString String
| VList Value
deriving (Show, Eq)
data Expr
= EVar String
| EValue Value
| EBinding String Expr
| EFunc String [String] Expr
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
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
parseValue :: Parser Expr
parseValue = EValue <$> Parser parse
where
parse ((Token (TInt n) _) : ts) = pure (VInt n, ts)
parse ((Token (TString s) _) : ts) = pure (VString s, ts)
parse _ = Left $ UnexpectedToken []
parseBinding :: Parser Expr
parseBinding = EBinding
<$> phrase
<*> expr <* sat (== KeywordIn)
where
phrase = sat (== KeywordLet) *> ident <* sat (== TEquals)
ident = Parser $ \((Token (TIdent name) _) : ts) -> pure (name, ts)
parseFunc :: Parser Expr
parseFunc = EFunc
<$> ident
<*> many ident <* sat (== TEquals)
<*> parseValue
where
parse ((Token (TIdent name) _) : ts) = pure (name, ts)
parse _ = Left NoParse
ident = Parser parse
expr :: Parser Expr
expr = parseValue <|> parseBinding
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]
-- parseBind :: Parser Expr
-- parseBind = EBinding <$> name <*> result
-- where
-- name = Parser $ \(t : ts) ->
-- case t of
-- (Token (TIdent s) _) -> pure (s, ts)
-- _ -> Left $ UnexpectedToken $ [TIdent ""]
-- result = Parser $ \(t : ts) ->
-- case t of
-- (Token (TInt n) _) -> pure (ELit n, ts)
-- _ -> Left $ UnexpectedToken $ [TIdent ""]
|
