lang/langfilter/Ebnf.hs

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