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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module K.NanoParsec where
import qualified Data.Text as T
import Control.Monad (when, MonadPlus(..))
import Control.Applicative ((<$>), Alternative(..))
import Control.Lens (_1, (&), (%~))
newtype Parser a = Parser { parse :: T.Text -> [(a, T.Text)] }
runParser :: Parser a -> T.Text -> Either T.Text a
runParser m t = case parse m t of
[(r, t')] -> do
when (not (T.null t')) (consumptionError t')
return r
_ -> Left "Parser error."
where consumptionError t =
Left ("Parser did not consume input: " `T.append` t)
bind :: Parser a -> (a -> Parser b) -> Parser b
bind p f = Parser $ \t -> (concat . fmap fp) (parse p t)
where fp (x, t') = parse (f x) t'
unit :: a -> Parser a
unit x = Parser (\t -> [(x, t)])
failure :: Parser a
failure = Parser (const [])
combine :: Parser a -> Parser a -> Parser a
combine p q = Parser $ \t -> parse p t ++ parse q t
option :: Parser a -> Parser a -> Parser a
option p q = Parser $ \t ->
case parse p t of
[] -> parse q t
res -> res
instance Functor Parser where
fmap f p = Parser $ \t -> f' <$> parse p t
where f' (x, t) = (f x, t)
instance Applicative Parser where
pure = unit
(Parser p1) <*> (Parser p2) = Parser $ \t ->
[(f x, t'') | (f, t') <- p1 t, (x, t'') <- p2 t']
instance Monad Parser where
return = unit
(>>=) = bind
instance Alternative Parser where
empty = mzero
(<|>) = option
instance MonadPlus Parser where
mzero = failure
mplus = combine
item :: Parser Char
item = Parser $ \t -> case T.uncons t of
Nothing -> []
Just (c, t) -> [(c, t)]
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do
c <- item
if p c
then unit c
else failure
|
