149 lines
3.8 KiB
Haskell
149 lines
3.8 KiB
Haskell
module Ebnf (makeEbnf, Rule (..), Def (..), render, parse) where
|
||
|
||
import Prelude hiding (span)
|
||
import Data.Maybe (fromMaybe)
|
||
import Data.List (intercalate)
|
||
import Data.Char (isAlphaNum)
|
||
import Text.ParserCombinators.ReadP
|
||
import Text.Pandoc.Definition
|
||
import Data.Text (Text, pack, unpack)
|
||
|
||
data Rule =
|
||
Rule Text Def
|
||
| RCom Text -- ^ @(* comment *)@
|
||
deriving (Eq, Show)
|
||
data Def =
|
||
N Text -- ^ @nonterminal@
|
||
| T Text -- ^ @\'terminal\'@ or @\"terminal\"@
|
||
| S Text -- ^ @?special?@
|
||
| Or [Def] -- ^ choice @a | b | c@
|
||
| Seq [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 $ fromMaybe (error "invalid ebnf") $ parse $ unpack 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 [Str txt]]]]
|
||
render1 (Rule name def) =
|
||
row' [span "ebnf-nt" name] "=" d : map (row' [] "|") ds
|
||
where
|
||
d:ds = splitOrs def
|
||
splitOrs (Or ds) = ds
|
||
splitOrs d = [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]
|
||
Or ds -> renderParens (p > OR) $
|
||
intercalate [Space, punc "|", Space] $ renderDefAt OR <$> ds
|
||
Seq ds -> renderParens (p > SEQ) $
|
||
intercalate [punc ",", Space] $ renderDefAt SEQ <$> 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]
|
||
|
||
|
||
|
||
parse :: String -> Maybe [Rule]
|
||
parse str =
|
||
case readP_to_S (parse' <* eof) str of
|
||
[(res, _)] -> Just res
|
||
_ -> Nothing
|
||
|
||
parse' :: ReadP [Rule]
|
||
parse' = many rule
|
||
|
||
rule = choice
|
||
[Rule <$> nt <* sym "=" <*> def <* sym ";",
|
||
RCom <$> comment]
|
||
|
||
nt = pack . unwords <$> many1 word
|
||
where word = munch1 isWordChar <* skipSpaces
|
||
isWordChar c = c == '_' || c == '-' || isAlphaNum c
|
||
|
||
def = ors
|
||
|
||
ors = list Or <$> seqs `sepBy1` (sym "|")
|
||
|
||
seqs = list Seq <$> sub `sepBy1` (sym ",")
|
||
|
||
sub = do
|
||
lhs <- adef
|
||
rhs <- optMaybe $ sym "-" *> adef
|
||
pure $ maybe lhs (Sub lhs) rhs
|
||
|
||
adef = choice $
|
||
[N <$> nt, T <$> term, S <$> special,
|
||
bracketed id '(' ')',
|
||
bracketed Opt '[' ']',
|
||
bracketed Many '{' '}',
|
||
Com <$> comment]
|
||
|
||
term = pack <$> choice [str '\'', str '"']
|
||
|
||
special = pack <$> str '?'
|
||
|
||
str c = lexeme $ between (char c) (char c) (munch1 (/= c))
|
||
|
||
comment = pack <$> lexeme go where
|
||
go = concat <$> sequence
|
||
[string "(*",
|
||
concat <$> many (choice [go, munch1 \c -> c /= '(' && c /= '*']),
|
||
string "*)"]
|
||
|
||
bracketed f o c = f <$> between (char' o) (char' c) def
|
||
|
||
list _ [x] = x
|
||
list f xs = f xs
|
||
|
||
|
||
sym str = lexeme $ string str
|
||
|
||
char' c = lexeme $ char c
|
||
|
||
lexeme p = p <* skipSpaces
|
||
|
||
optMaybe = option Nothing . fmap Just
|