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
|
{------------------------------------------------------------------------------
Control.Monad.Operational
Example:
A reformulation of Koen Claessen's Parallel Parsing Processes
http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217
For a detailed explanation, see also
http://apfelmus.nfshost.com/articles/operational-monad.html#monadic-parser-combinators
------------------------------------------------------------------------------}
{-# LANGUAGE GADTs, Rank2Types, TypeSynonymInstances #-}
module BreadthFirstParsing where
import Control.Monad
import Control.Monad.Operational
{------------------------------------------------------------------------------
At their core, a parser monad consists of just three
primitive instructions
symbol -- fetch the next character
mzero -- indicate parse failure
mplus -- non-deterministic choice between two parsers
and an interpreter function
parse :: Parser a -> (String -> [a])
that applies a parser to a string and returns
all the possible parse results.
------------------------------------------------------------------------------}
data ParserInstruction a where
Symbol :: ParserInstruction Char
MZero :: ParserInstruction a
MPlus :: Parser a -> Parser a -> ParserInstruction a
type Parser = Program ParserInstruction
symbol = singleton Symbol
instance MonadPlus Parser where
mzero = singleton $ MZero
mplus x y = singleton $ MPlus x y
-- apply a parser to a string
-- breadth first fashion: each input character is touched only once
parse :: Parser a -> String -> [a]
parse p = go (expand p)
where
go :: [Parser a] -> String -> [a]
go ps [] = [a | Return a <- map view ps]
go ps (c:cs) = go [p | (Symbol :>>= is) <- map view ps, p <- expand (is c)] cs
-- keep track of parsers that are run in parallel
expand :: Parser a -> [Parser a]
expand p = case view p of
MPlus p q :>>= k -> expand (p >>= k) ++ expand (q >>= k)
MZero :>>= k -> []
_ -> [p]
-- example
-- > parse parens "()(()())"
-- [()] -- one parse
-- > parse parens "()((())"
-- [] -- no parse
parens :: Parser ()
parens = return () `mplus` (enclose parens >> parens)
where
enclose q = char '(' >> q >> char ')'
many :: Parser a -> Parser [a]
many p = mzero `mplus` liftM2 (:) p (many p)
satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do c <- symbol; if p c then return c else mzero
char c = satisfy (==c)
|
