lang/langfilter/Ebnf.hs

200 lines
5.5 KiB
Haskell
Raw Normal View History

2021-04-28 06:37:42 -04:00
module Ebnf (makeEbnf, Rule (..), Def (..), render, parse) where
import Prelude hiding (span)
import Data.List (intercalate)
import Data.Char (isAlphaNum)
2021-06-03 23:21:47 -04:00
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char hiding (char')
import qualified Text.Megaparsec as MP
2021-04-28 06:37:42 -04:00
import Text.Pandoc.Definition
2021-06-03 23:21:47 -04:00
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void
2023-12-23 19:41:12 -05:00
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
2021-04-28 06:37:42 -04:00
data Rule =
2024-11-26 00:07:57 -05:00
Rule Text [Text] Def
2021-04-28 06:37:42 -04:00
| RCom Text -- ^ @(* comment *)@
deriving (Eq, Show)
data Def =
2024-11-26 00:07:57 -05:00
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
2021-04-28 06:37:42 -04:00
deriving (Eq, Show)
makeEbnf :: Block -> Block
makeEbnf (CodeBlock (_, cs, _) txt)
| "ebnf" `elem` cs
2021-06-03 23:21:47 -04:00
= render $ either (error . errorBundlePretty) id $ parse txt
2021-04-28 06:37:42 -04:00
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) =
2024-11-26 00:07:57 -05:00
[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
2021-04-28 06:37:42 -04:00
where
2024-11-26 00:07:57 -05:00
lhs = case args of
[] -> [span "ebnf-nt" name]
_ -> [span "ebnf-f" name, punc "("] ++
intercalate [punc ";", Space] [[span "ebnf-nt" x] | x <- args] ++
[punc ")"]
2023-12-23 19:41:12 -05:00
d :| ds = splitOrs def
2021-04-28 06:37:42 -04:00
splitOrs (Or ds) = ds
2023-12-23 19:41:12 -05:00
splitOrs d = NonEmpty.singleton d
2021-04-28 06:37:42 -04:00
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]
2024-11-26 00:07:57 -05:00
C f xs ->
[span "ebnf-f" f, punc "("] ++
intercalate [punc ";", Space] (renderDefAt OUTER <$> NonEmpty.toList xs) ++
[punc ")"]
2021-04-28 06:37:42 -04:00
Or ds -> renderParens (p > OR) $
2023-12-23 19:41:12 -05:00
intercalate [Space, punc "|", Space] $ renderDefAt OR <$> NonEmpty.toList ds
2021-04-28 06:37:42 -04:00
Seq ds -> renderParens (p > SEQ) $
2023-12-23 19:41:12 -05:00
intercalate [punc ",", Space] $ renderDefAt SEQ <$> NonEmpty.toList ds
2021-04-28 06:37:42 -04:00
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]
2021-06-03 23:21:47 -04:00
type P = Parsec Void Text
2021-04-28 06:37:42 -04:00
2021-06-03 23:21:47 -04:00
parse :: Text -> Either (ParseErrorBundle Text Void) [Rule]
parse str = MP.parse (parse' <* eof) "<ebnf>" str
2021-04-28 06:37:42 -04:00
2021-06-03 23:21:47 -04:00
parse' :: Parsec Void Text [Rule]
2021-04-28 06:37:42 -04:00
parse' = many rule
2021-06-03 23:21:47 -04:00
rule :: P Rule
2021-04-28 06:37:42 -04:00
rule = choice
2024-11-26 00:07:57 -05:00
[Rule <$> nt <*> lhsArgs <* sym "=" <*> def <* sym ";",
2021-04-28 06:37:42 -04:00
RCom <$> comment]
2024-11-26 00:07:57 -05:00
lhsArgs :: P [Text]
lhsArgs =
sym "(" *> nt `sepBy1` sym ";" <* sym ")"
<|> pure []
2021-06-03 23:21:47 -04:00
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
2021-04-28 06:37:42 -04:00
2021-06-03 23:21:47 -04:00
def :: P Def
2021-04-28 06:37:42 -04:00
def = ors
2021-06-03 23:21:47 -04:00
ors :: P Def
2024-11-26 00:07:57 -05:00
ors = list1 Or <$> seqs `sepBy1'` sym "|"
2021-04-28 06:37:42 -04:00
2021-06-03 23:21:47 -04:00
seqs :: P Def
2024-11-26 00:07:57 -05:00
seqs = list1 Seq <$> sub `sepBy1'` sym ","
2023-12-23 19:41:12 -05:00
sepBy1' :: P a -> P z -> P (NonEmpty a)
sepBy1' a b = NonEmpty.fromList <$> sepBy1 a b
2021-04-28 06:37:42 -04:00
2021-06-03 23:21:47 -04:00
sub :: P Def
2021-04-28 06:37:42 -04:00
sub = do
lhs <- adef
rhs <- optMaybe $ sym "-" *> adef
pure $ maybe lhs (Sub lhs) rhs
2021-06-03 23:21:47 -04:00
adef :: P Def
2021-04-28 06:37:42 -04:00
adef = choice $
2024-11-26 00:07:57 -05:00
[call, T <$> term, S <$> special,
2021-06-03 23:21:47 -04:00
Com <$> comment,
2021-04-28 06:37:42 -04:00
bracketed id '(' ')',
bracketed Opt '[' ']',
2021-06-03 23:21:47 -04:00
bracketed Many '{' '}']
2024-11-26 00:07:57 -05:00
call :: P Def
call = do
f <- nt
args <- optional $ sym "(" *> def `sepBy1` (sym ";") <* sym ")"
pure $ maybe (N f) (C f . NonEmpty.fromList) args
2021-06-03 23:21:47 -04:00
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
2024-11-26 00:07:57 -05:00
go acc 0 = mconcat (reverse acc) <$ space
2021-06-03 23:21:47 -04:00
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
2021-04-28 06:37:42 -04:00
bracketed f o c = f <$> between (char' o) (char' c) def
2023-12-23 19:41:12 -05:00
list1 :: (NonEmpty a -> a) -> NonEmpty a -> a
list1 _ (x :| []) = x
list1 f xs = f xs
2021-04-28 06:37:42 -04:00
2021-06-03 23:21:47 -04:00
sym :: Text -> P Text
2021-04-28 06:37:42 -04:00
sym str = lexeme $ string str
2021-06-03 23:21:47 -04:00
char' :: Char -> P Char
2021-04-28 06:37:42 -04:00
char' c = lexeme $ char c
2021-06-03 23:21:47 -04:00
lexeme :: P a -> P a
2024-11-26 00:07:57 -05:00
lexeme p = try $ p <* space
2021-04-28 06:37:42 -04:00
2021-06-03 23:21:47 -04:00
optMaybe :: P a -> P (Maybe a)
2021-04-28 06:37:42 -04:00
optMaybe = option Nothing . fmap Just