From 6f2fa30212d18fb8eb125b8e5b44464ebfc3717d Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Wed, 28 Apr 2021 12:37:42 +0200 Subject: [PATCH] add ebnf highlighting filter --- langfilter/Ebnf.hs | 148 ++++++++++++++++++++++++++++++++++++ langfilter/langfilter.cabal | 2 + langfilter/langfilter.hs | 3 + style/page.css | 32 ++++++++ 4 files changed, 185 insertions(+) create mode 100644 langfilter/Ebnf.hs diff --git a/langfilter/Ebnf.hs b/langfilter/Ebnf.hs new file mode 100644 index 0000000..254b31f --- /dev/null +++ b/langfilter/Ebnf.hs @@ -0,0 +1,148 @@ +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 diff --git a/langfilter/langfilter.cabal b/langfilter/langfilter.cabal index 3440006..70a32a4 100644 --- a/langfilter/langfilter.cabal +++ b/langfilter/langfilter.cabal @@ -10,6 +10,8 @@ maintainer: Rhiannon Morris executable langfilter hs-source-dirs: . main-is: langfilter.hs + other-modules: + Ebnf ghc-options: -Wall -Wno-missing-signatures -Wno-missing-pattern-synonym-signatures -Wno-name-shadowing diff --git a/langfilter/langfilter.hs b/langfilter/langfilter.hs index 0772f75..4646524 100644 --- a/langfilter/langfilter.hs +++ b/langfilter/langfilter.hs @@ -1,3 +1,5 @@ +import Ebnf + import Text.Pandoc.Definition import Text.Pandoc.JSON import Text.Pandoc.Builder @@ -10,6 +12,7 @@ import qualified Data.Text as Text main :: IO () main = toJSONFilter (filter :: Pandoc -> Pandoc) where filter = + walk makeEbnf . walk (concatMap makeFigures) . walk spans . walk (concatMap glosses) diff --git a/style/page.css b/style/page.css index e0739e7..00ee766 100644 --- a/style/page.css +++ b/style/page.css @@ -216,3 +216,35 @@ footer { font-weight: 500; text-align: center; } + +.ebnf { + border: none; +} + +.ebnf td { + padding: 0 0.15em; +} + +.ebnf-nt { + font-weight: 500; + color: hsl(155deg, 80%, 30%); + white-space: nowrap; +} + +.ebnf-punc { + color: hsl(25deg, 40%, 30%); +} + +.ebnf-sub, .ebnf-brack { + color: hsl(210deg, 80%, 35%); + font-weight: 500; +} + +.ebnf-brack { + padding: 0 0.05em; +} + +.ebnf-s { + font-style: italic; + color: hsl(330deg, 80%, 30%); +}