/
BNFEx.hs
95 lines (78 loc) · 2.22 KB
/
BNFEx.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
module BNFEx where
import Control.Applicative
import Data.Foldable
import Data.Functor
import Data.Char
import qualified Data.Map as M
import RParser
-- A type for simple grammars
type Ident = String
type RuleRhs = [Seq]
type Seq = [Atom]
data Atom = Lit String | NonTerm Ident deriving Show
type Rule = (Ident, RuleRhs)
type BNF = [Rule]
-- a parser for simple BNF syntax
type P = Parser Char
snoc :: [a] -> a -> [a]
snoc xs x = xs ++ [x]
l :: P a -> P a
--l p = p <|> l p <* sat isSpace
l p = p' where -- NB: Sharing!
p' = p <|> p' <* sat isSpace
quote :: P Char
quote = tok '\''
quoted :: P a -> P a
quoted p = quote *> p <* quote
str :: P String
str = some (sat (not . (== '\'')))
ident :: P Ident
ident = some (sat (\c -> isAlphaNum c && isAscii c))
atom :: P Atom
atom = Lit <$> l (quoted str)
<|> NonTerm <$> l ident
eps :: P ()
eps = void $ l (tok 'ε')
sep :: P ()
sep = void $ some (sat isSpace)
sq :: P Seq
sq = [] <$ eps
<|> snoc <$> sq <* sep <*> atom
<|> pure <$> atom
ruleRhs :: P RuleRhs
ruleRhs = pure <$> sq
<|> snoc <$> ruleRhs <* l (tok '|') <*> sq
rule :: P Rule
rule = (,) <$> l ident <* l (tok ':' *> tok '=') <*> ruleRhs <* l (tok ';')
bnf :: P BNF
bnf = pure <$> rule
<|> snoc <$> bnf <*> rule
-- An example
numExp :: String
numExp = unlines
[ "term := sum;"
, "pdigit := '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9';"
, "digit := '0' | pdigit;"
, "pnum := pdigit | pnum digit;"
, "num := '0' | pnum;"
, "prod := atom | atom '*' prod;"
, "sum := prod | prod '+' sum;"
, "atom := num | '(' term ')';"
]
-- Interpreting a BNF, producing a parse tree, i.e. noting which
-- non-terminal fired
interp :: BNF -> P String
interp bnf = parsers M.! start
where
start :: Ident
start = fst (head bnf)
parsers :: M.Map Ident (P String)
parsers = M.fromList [ (i, parseRule i rhs) | (i, rhs) <- bnf ]
parseRule :: Ident -> RuleRhs -> P String
parseRule ident rhs = trace <$> asum (map parseSeq rhs)
where trace s = ident ++ "(" ++ s ++ ")"
parseSeq :: Seq -> P String
parseSeq = fmap concat . traverse parseAtom
parseAtom :: Atom -> P String
parseAtom (Lit s) = traverse tok s
parseAtom (NonTerm i) = parsers M.! i