rhi/lang
1
0
Fork 0
Code Issues 2 Pull requests Releases Wiki Activity

parameterised rules in ebnf

Browse source
This commit is contained in:
Rhiannon Morris 2024-11-26 06:07:57 +01:00
parent 3cd2c59be2
commit 54a8aa1119
1 changed files with 41 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

60
langfilter/Ebnf.hs
View file

@ -14,19 +14,20 @@ import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
data Rule =
Rule Text Def
Rule Text [Text] Def
| RCom Text -- ^ @(* comment *)@
deriving (Eq, Show)
data Def =
N Text -- ^ @nonterminal@
| T Text -- ^ @\'terminal\'@ or @\"terminal\"@
| S Text -- ^ @?special?@
| Or (NonEmpty Def) -- ^ choice @a | b | c@
| Seq (NonEmpty Def) -- ^ sequence @a, b, c@
| Sub Def Def -- ^ difference @a - b@
| Opt Def -- ^ opt @[a]@
| Many Def -- ^ repetition @{a}@
| Com Text -- ^ comment
N Text -- ^ @nonterminal@
| T Text -- ^ @\'terminal\'@ or @\"terminal\"@
| S Text -- ^ @?special?@
| C Text (NonEmpty Def) -- ^ @param(X, Y)@
| Or (NonEmpty Def) -- ^ choice @a | b | c@
| Seq (NonEmpty Def) -- ^ sequence @a, b, c@
| Sub Def Def -- ^ difference @a - b@
| Opt Def -- ^ opt @[a]@
| Many Def -- ^ repetition @{a}@
| Com Text -- ^ comment
deriving (Eq, Show)
@ -49,10 +50,16 @@ render rs =
render1 :: Rule -> [Row]
render1 (RCom txt) =
[Row mempty [Cell mempty AlignLeft (RowSpan 1) (ColSpan 3) [Plain [Str txt]]]]
render1 (Rule name def) =
row' [span "ebnf-nt" name] "=" d : map (row' [] "|") ds
[Row mempty [Cell mempty AlignLeft (RowSpan 1) (ColSpan 3)
[Plain [span "ebnf-com" txt]]]]
render1 (Rule name args def) =
row' lhs "=" d : map (row' [] "|") ds
where
lhs = case args of
[] -> [span "ebnf-nt" name]
_ -> [span "ebnf-f" name, punc "("] ++
intercalate [punc ";", Space] [[span "ebnf-nt" x] | x <- args] ++
[punc ")"]
d :| ds = splitOrs def
splitOrs (Or ds) = ds
splitOrs d = NonEmpty.singleton d
@ -77,6 +84,10 @@ renderDefAt p = \case
N txt -> [span "ebnf-nt" txt]
T txt -> [span "ebnf-t" txt]
S txt -> [span "ebnf-s" txt]
C f xs ->
[span "ebnf-f" f, punc "("] ++
intercalate [punc ";", Space] (renderDefAt OUTER <$> NonEmpty.toList xs) ++
[punc ")"]
Or ds -> renderParens (p > OR) $
intercalate [Space, punc "|", Space] $ renderDefAt OR <$> NonEmpty.toList ds
Seq ds -> renderParens (p > SEQ) $
@ -100,9 +111,14 @@ parse' = many rule
rule :: P Rule
rule = choice
[Rule <$> nt <* sym "=" <*> def <* sym ";",
[Rule <$> nt <*> lhsArgs <* sym "=" <*> def <* sym ";",
RCom <$> comment]
lhsArgs :: P [Text]
lhsArgs =
sym "(" *> nt `sepBy1` sym ";" <* sym ")"
<|> pure []
nt :: P Text
nt = Text.unwords <$> some (word <* space) where
word = Text.cons <$> first <*> takeWhileP Nothing isWordChar
@ -113,10 +129,10 @@ def :: P Def
def = ors
ors :: P Def
ors = list1 Or <$> seqs `sepBy1'` (sym "|")
ors = list1 Or <$> seqs `sepBy1'` sym "|"
seqs :: P Def
seqs = list1 Seq <$> sub `sepBy1'` (sym ",")
seqs = list1 Seq <$> sub `sepBy1'` sym ","
sepBy1' :: P a -> P z -> P (NonEmpty a)
sepBy1' a b = NonEmpty.fromList <$> sepBy1 a b
@ -129,12 +145,18 @@ sub = do
adef :: P Def
adef = choice $
[N <$> nt, T <$> term, S <$> special,
[call, T <$> term, S <$> special,
Com <$> comment,
bracketed id '(' ')',
bracketed Opt '[' ']',
bracketed Many '{' '}']
call :: P Def
call = do
f <- nt
args <- optional $ sym "(" *> def `sepBy1` (sym ";") <* sym ")"
pure $ maybe (N f) (C f . NonEmpty.fromList) args
term :: P Text
term = choice [str '\'', str '"']
@ -147,7 +169,7 @@ str c = lexeme $ between (char c) (char c) (takeWhileP Nothing (/= c))
comment :: P Text
comment = do try (string_ "(*"); go ["(*"] 1 where
go :: [Text] -> Int -> P Text
go acc 0 = pure $ mconcat $ reverse acc
go acc 0 = mconcat (reverse acc) <$ space
go acc i = choice
[fragment (string "(*") (+ 1) acc i,
fragment (string "*)") (subtract 1) acc i,
@ -171,7 +193,7 @@ char' :: Char -> P Char
char' c = lexeme $ char c
lexeme :: P a -> P a
lexeme p = p <* space
lexeme p = try $ p <* space
optMaybe :: P a -> P (Maybe a)
optMaybe = option Nothing . fmap Just