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