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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
module Hint.Lexer where
import Control.Applicative (Alternative (..), asum)
import Data.Char (isAlpha, isDigit, isSpace)
type Input = String
data SourcePos = SourcePos
{ line :: Int
, column :: Int}
deriving (Show, Eq)
data LexerState = LexerState
{ sourcepos :: SourcePos
, input :: String
} deriving (Show, Eq)
data LexError
= UnexpectedEof
| IllegalChar Char
| UnexpectedChar SourcePos [Char]
| NoMatch
-- ^ Used for Alternative implementation
deriving (Show, Eq)
data TokenKind
= TIdent String
| TInt Int
| TString String
| TOpenParen
| TCloseParen
| TOpenCurly
| TCloseCurly
| TOpenSquare
| TCloseSquare
| TComma
| TEof
| TPlus
| TMinus
| TEquals
| KeywordLet
| KeywordIn
deriving (Show, Eq)
data Span = Span SourcePos SourcePos
deriving (Show, Eq)
data Token = Token TokenKind Span
deriving (Show, Eq)
getKind :: Token -> TokenKind
getKind (Token kind _) = kind
newtype Lexer a = Lexer
{ unLexer :: LexerState -> Either LexError (a, LexerState) }
instance Functor Lexer where
fmap f (Lexer lf) = Lexer $ \s -> do
(c, s') <- lf s
pure (f c, s')
instance Applicative Lexer where
pure a = Lexer $ \s -> Right (a, s)
Lexer lf <*> Lexer lx = Lexer $ \s -> do
(f, s') <- lf s
(x, s'') <- lx s'
pure (f x, s'')
instance Alternative Lexer where
empty = Lexer $ \_ -> Left NoMatch
Lexer p <|> Lexer q = Lexer $ \s ->
case p s of
Right n -> Right n
Left _ -> q s
instance Monad Lexer where
return = pure
Lexer lx >>= f = Lexer $ \s -> do
(x, s') <- lx s
unLexer (f x) s'
-- | Toplevel interface to lexer
runLexer :: Lexer a -> Input -> Either LexError (a, LexerState)
runLexer lx = unLexer lx . LexerState (SourcePos 1 1)
runProd :: Input -> Either LexError [Token]
runProd = fmap fst . runLexer gram
-- | Lifts `TokenKind` lexers into Token by tracking span information behind the
-- scenes.
token :: Lexer TokenKind -> Lexer Token
token (Lexer p) = Lexer $ \st -> do
let start = sourcepos st
(kind, st') <- p st
let end = sourcepos st'
pure $ (Token kind (Span start end), st')
lexChar :: Lexer Char
lexChar = Lexer $ \st ->
case input st of
[] -> Left UnexpectedEof
('\n' : rest) -> Right ('\n', st {sourcepos = withNewLine st, input = rest})
(c : rest) -> Right (c, st { sourcepos = withNewCol st, input = rest })
where
withNewLine, withNewCol :: LexerState -> SourcePos
withNewLine = liftA2 SourcePos ((+ 1) . line . sourcepos) (pure 1)
withNewCol = liftA2 SourcePos (line . sourcepos) ((+ 1) . column . sourcepos)
-- lexEof :: Lexer TokenKind
-- lexEof = Lexer $ \st ->
-- case input st of
-- [] -> pure (TEof, st)
-- _ -> Left $ UnexpectedChar $ sourcepos st
sat :: (Char -> Bool) -> Lexer Char
sat p = do
c <- lexChar
if p c then pure c else Lexer $ \s -> Left (UnexpectedChar (sourcepos s) [c])
string :: String -> Lexer String
string = traverse (\c -> sat (== c))
lexKeyword :: Lexer TokenKind
lexKeyword = asum $
[ KeywordLet <$ string "let"
, KeywordIn <$ string "in"
]
lexIdent :: Lexer TokenKind
lexIdent = TIdent <$> liftA2 (:) (sat isAlpha) (many rest)
where
-- characters allowed ofter the initial a-z
rest = asum $ sat <$> [isAlpha, isDigit, (== '\'')]
lexNumber :: Lexer TokenKind
lexNumber = TInt . read <$> some (sat isDigit)
lexString :: Lexer TokenKind
lexString = TString <$> (sat (== '\"') *> many (sat (/= '\"')) <* sat (== '\"'))
spaces :: Lexer [()]
spaces = many $ () <$ sat isSpace
gram :: Lexer [Token]
gram = some $ spaces *> asum lexers
where
lexers = map token $
[ TOpenParen <$ sat (== '(')
, TCloseParen <$ sat (== ')')
, TOpenCurly <$ sat (== '{')
, TCloseCurly <$ sat (== '}')
, TOpenSquare <$ sat (== '[')
, TCloseSquare <$ sat (== ']')
, TComma <$ sat (== ',')
, TPlus <$ sat (== '+')
, TMinus <$ sat (== '-')
, TEquals <$ sat (== '=')
, lexKeyword
, lexIdent
, lexNumber
, lexString
]
|
