199 lines
5.5 KiB
Haskell
199 lines
5.5 KiB
Haskell
module Ebnf (makeEbnf, Rule (..), Def (..), render, parse) where
|
||
|
||
import Prelude hiding (span)
|
||
import Data.List (intercalate)
|
||
import Data.Char (isAlphaNum)
|
||
import Text.Megaparsec hiding (parse)
|
||
import Text.Megaparsec.Char hiding (char')
|
||
import qualified Text.Megaparsec as MP
|
||
import Text.Pandoc.Definition
|
||
import Data.Text (Text)
|
||
import qualified Data.Text as Text
|
||
import Data.Void
|
||
import Data.List.NonEmpty (NonEmpty (..))
|
||
import qualified Data.List.NonEmpty as NonEmpty
|
||
|
||
data Rule =
|
||
Rule Text [Text] Def
|
||
| RCom Text -- ^ @(* comment *)@
|
||
deriving (Eq, Show)
|
||
data Def =
|
||
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)
|
||
|
||
|
||
makeEbnf :: Block -> Block
|
||
makeEbnf (CodeBlock (_, cs, _) txt)
|
||
| "ebnf" `elem` cs
|
||
= render $ either (error . errorBundlePretty) id $ parse txt
|
||
makeEbnf b = b
|
||
|
||
render :: [Rule] -> Block
|
||
render rs =
|
||
Table ("", ["ebnf"], [])
|
||
(Caption Nothing [])
|
||
[(AlignRight, ColWidthDefault),
|
||
(AlignCenter, ColWidthDefault),
|
||
(AlignLeft, ColWidthDefault)]
|
||
(TableHead mempty [])
|
||
[TableBody mempty (RowHeadColumns 0) [] (concatMap render1 rs)]
|
||
(TableFoot mempty [])
|
||
|
||
render1 :: Rule -> [Row]
|
||
render1 (RCom txt) =
|
||
[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
|
||
row' c1 p d = Row mempty [cell c1, cell [punc p], cell (renderDef d)]
|
||
cell is = Cell mempty AlignDefault (RowSpan 1) (ColSpan 1) [Plain is]
|
||
|
||
span c str = Span ("", [c], []) [Str str]
|
||
punc = span "ebnf-punc"
|
||
brack = span "ebnf-brack"
|
||
|
||
data Prec = OUTER | OR | SEQ | SUB deriving (Eq, Ord)
|
||
|
||
renderParens :: Bool -> [Inline] -> [Inline]
|
||
renderParens False is = is
|
||
renderParens True is = [punc "("] <> is <> [punc ")"]
|
||
|
||
renderDef :: Def -> [Inline]
|
||
renderDef = renderDefAt OUTER
|
||
|
||
renderDefAt :: Prec -> Def -> [Inline]
|
||
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) $
|
||
intercalate [punc ",", Space] $ renderDefAt SEQ <$> NonEmpty.toList ds
|
||
Sub d e -> renderParens (p >= SUB) $
|
||
renderDefAt SUB d <>
|
||
[Space, span "ebnf-sub" "−", Space] <>
|
||
renderDefAt SUB e
|
||
Opt d -> [brack "["] <> renderDef d <> [brack "]"]
|
||
Many d -> [brack "{"] <> renderDef d <> [brack "}"]
|
||
Com txt -> [span "ebnf-com" txt]
|
||
|
||
|
||
type P = Parsec Void Text
|
||
|
||
parse :: Text -> Either (ParseErrorBundle Text Void) [Rule]
|
||
parse str = MP.parse (parse' <* eof) "<ebnf>" str
|
||
|
||
parse' :: Parsec Void Text [Rule]
|
||
parse' = many rule
|
||
|
||
rule :: P Rule
|
||
rule = choice
|
||
[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
|
||
first = letterChar
|
||
isWordChar c = c == '_' || c == '-' || isAlphaNum c
|
||
|
||
def :: P Def
|
||
def = ors
|
||
|
||
ors :: P Def
|
||
ors = list1 Or <$> seqs `sepBy1'` sym "|"
|
||
|
||
seqs :: P Def
|
||
seqs = list1 Seq <$> sub `sepBy1'` sym ","
|
||
|
||
sepBy1' :: P a -> P z -> P (NonEmpty a)
|
||
sepBy1' a b = NonEmpty.fromList <$> sepBy1 a b
|
||
|
||
sub :: P Def
|
||
sub = do
|
||
lhs <- adef
|
||
rhs <- optMaybe $ sym "-" *> adef
|
||
pure $ maybe lhs (Sub lhs) rhs
|
||
|
||
adef :: P Def
|
||
adef = choice $
|
||
[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 '"']
|
||
|
||
special :: P Text
|
||
special = str '?'
|
||
|
||
str :: Char -> P Text
|
||
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 = mconcat (reverse acc) <$ space
|
||
go acc i = choice
|
||
[fragment (string "(*") (+ 1) acc i,
|
||
fragment (string "*)") (subtract 1) acc i,
|
||
fragment (takeWhileP Nothing notComChar) id acc i]
|
||
fragment p f acc i = do str <- p; go (str : acc) (f i)
|
||
notComChar c = c /= '(' && c /= '*'
|
||
string_ str = () <$ string str
|
||
|
||
bracketed :: (Def -> a) -> Char -> Char -> P a
|
||
bracketed f o c = f <$> between (char' o) (char' c) def
|
||
|
||
list1 :: (NonEmpty a -> a) -> NonEmpty a -> a
|
||
list1 _ (x :| []) = x
|
||
list1 f xs = f xs
|
||
|
||
|
||
sym :: Text -> P Text
|
||
sym str = lexeme $ string str
|
||
|
||
char' :: Char -> P Char
|
||
char' c = lexeme $ char c
|
||
|
||
lexeme :: P a -> P a
|
||
lexeme p = try $ p <* space
|
||
|
||
optMaybe :: P a -> P (Maybe a)
|
||
optMaybe = option Nothing . fmap Just
|