-
Notifications
You must be signed in to change notification settings - Fork 0
/
paars.hs
115 lines (86 loc) · 2.9 KB
/
paars.hs
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
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MonadComprehensions #-}
import Control.Applicative (liftA)
import Control.Monad (MonadPlus)
import Data.Bifunctor (first)
import Data.Char
import GHC.Base (Alternative, empty, (<|>))
newtype Paars a = Paars (String -> [(a, String)])
instance Functor Paars where
fmap :: (a -> b) -> Paars a -> Paars b
fmap = liftA
instance Applicative Paars where
-- always succeeds, returning val and unmodified input
pure :: a -> Paars a
pure val = Paars (\inp -> [(val, inp)])
(<*>) :: Paars (a -> b) -> Paars a -> Paars b
Paars pAB <*> Paars pA = Paars (concatMap (\(f, inp') -> map (first f) (pA inp')) . pAB)
-- todo: is this equivalent?
-- Paars (\inp -> [(ab a, inp'') | (a, inp') <- pA inp, (ab, inp'') <- pAB inp'])
instance Monad Paars where
return :: a -> Paars a
return = pure
-- takes a parser of as and a function from a to a parser of bs
-- returns a parser of bs
-- the resultant parser applies func to all results of pA
(>>=) :: Paars a -> (a -> Paars b) -> Paars b
Paars pA >>= func = Paars (concatMap (\(v, inp') -> run (func v) inp') . pA)
instance Alternative Paars where
-- always fails
empty :: Paars a
empty = Paars (const [])
-- takes two parsers of as and returns a parser of as
-- the resultant parser returns results from both parsers
(<|>) :: Paars a -> Paars a -> Paars a
Paars p1 <|> Paars p2 = Paars (\inp -> p1 inp ++ p2 inp)
instance MonadPlus Paars
run :: Paars a -> String -> [(a, String)]
run (Paars f) = f
-- returns the first character of input
item :: Paars Char
item = Paars item'
where
item' (c : cs) = [(c, cs)]
item' _ = []
-- parses a char iff it satisfies predicate
sat :: (Char -> Bool) -> Paars Char
sat predicate = [x | x <- item, predicate x]
-- some useful parsers
char :: Char -> Paars Char
char c = sat (c ==)
digit :: Paars Char
digit = sat isDigit
lower :: Paars Char
lower = sat isLower
upper :: Paars Char
upper = sat isUpper
letter :: Paars Char
letter = lower <|> upper
alphanum :: Paars Char
alphanum = letter <|> digit
string :: String -> Paars String
string "" = pure ""
string (c : cs) = [c : cs | _ <- char c, _ <- string cs]
byte :: Paars Int
byte = [val | x <- digit, let val = digitToInt x, val < 8]
-- repetition parsers
-- todo: naming?
many :: Paars a -> Paars [a]
many pA = [x : xs | x <- pA, xs <- many pA] <|> pure []
many1 :: Paars a -> Paars [a]
many1 pA = [x : xs | x <- pA, xs <- many pA]
word :: Paars String
word = many letter
nat :: Paars Int
nat = [read xs | xs <- many1 digit]
int :: Paars Int
int = nat <|> [- n | _ <- char '-', n <- nat, n /= 0]
-- int can also be defined as:
--
-- int = [f n | f <- operator, n <- nat, n /= 0]
-- where
-- operator = [negate | _ <- char '-'] <|> pure id
--
-- on input "-123": operator = [(negate, "123"), (id, "-123")]
-- n <- nat will fail on this ^
-- so id is not used in this case