parameterised rules in ebnf

langfilter/Ebnf.hs

@@ -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