lang/langfilter/Ebnf.hs

173 lines
4.6 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
2021-04-28 06:37:42 -04:00
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
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) =
[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]
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
[Rule <$> nt <* sym "=" <*> def <* sym ";",
RCom <$> comment]
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
2021-04-28 06:37:42 -04:00
ors = list Or <$> seqs `sepBy1` (sym "|")
2021-06-03 23:21:47 -04:00
seqs :: P Def
2021-04-28 06:37:42 -04:00
seqs = list Seq <$> sub `sepBy1` (sym ",")
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 $
[N <$> nt, 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 '{' '}']
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 = pure $ mconcat $ reverse acc
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
2021-06-03 23:21:47 -04:00
list :: ([a] -> a) -> [a] -> a
2021-04-28 06:37:42 -04:00
list _ [x] = x
list f xs = f xs
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
lexeme p = 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