{-
    BNF Converter: Pretty-printer generator
    Copyright (C) 2005  Author:  Kristofer Johannisson

-}

-- based on BNFC Haskell backend

{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.OCaml.CFtoOCamlPrinter (cf2Printer, prtFun) where

import Prelude hiding ((<>))

import Data.Char(toLower)
import Data.List (intersperse, sortBy)
import Data.Maybe (fromJust)

import BNFC.CF
import BNFC.Utils
import BNFC.Backend.OCaml.OCamlUtil
import BNFC.PrettyPrint
import BNFC.Backend.Haskell.CFtoPrinter (compareRules)


-- derive pretty-printer from a BNF grammar. AR 15/2/2002
cf2Printer :: String -> ModuleName -> CF -> String
cf2Printer :: [Char] -> [Char] -> CF -> [Char]
cf2Printer [Char]
_name [Char]
absMod CF
cf = [[Char]] -> [Char]
unlines [
  [Char]
prologue,
  CF -> [Char]
charRule CF
cf,
  CF -> [Char]
integerRule CF
cf,
  CF -> [Char]
doubleRule CF
cf,
  CF -> [Char]
stringRule CF
cf,
  if CF -> Bool
forall f. CFG f -> Bool
hasIdent CF
cf then [Char] -> CF -> [Char]
identRule [Char]
absMod CF
cf else [Char]
"",
  [[Char]] -> [Char]
unlines [[Char] -> CF -> [Char] -> [Char]
ownPrintRule [Char]
absMod CF
cf [Char]
own | ([Char]
own,Reg
_) <- CF -> [([Char], Reg)]
forall f. CFG f -> [([Char], Reg)]
tokenPragmas CF
cf],
  [Char] -> CF -> [Char]
rules [Char]
absMod CF
cf
  ]


prologue :: String
prologue :: [Char]
prologue = [[Char]] -> [Char]
unlines [
  [Char]
"(* pretty-printer *)",
  [Char]
"",
  [Char]
"open Printf",
  [Char]
"",
  [Char]
"(* We use string buffers for efficient string concatenation.",
  [Char]
"   A document takes a buffer and an indentation, has side effects on the buffer",
  [Char]
"   and returns a new indentation. The indentation argument indicates the level",
  [Char]
"   of indentation to be used if a new line has to be started (because of what is",
  [Char]
"   already in the buffer) *)",
  [Char]
"type doc = Buffer.t -> int -> int",
  [Char]
"",
  [Char]
"let rec printTree (printer : int -> 'a -> doc) (tree : 'a) : string = ",
  [Char]
"    let buffer_init_size = 64 (* you may want to change this *)",
  [Char]
"    in let buffer = Buffer.create buffer_init_size",
  [Char]
"    in ",
  [Char]
"        let _ = printer 0 tree buffer 0 in (* discard return value *)",
  [Char]
"        Buffer.contents buffer",
  [Char]
"",
  [Char]
"let indent_width = 2",
  [Char]
"",
  [Char]
"let spaces (i: int) : string = if i > 0 then String.make i ' ' else \"\"",
  [Char]
"let indent (i: int) : string = \"\\n\" ^ spaces i",
  [Char]
"",
  [Char]
"(* To avoid dependency on package extlib, which has",
  [Char]
"   Extlib.ExtChar.Char.is_whitespace, we employ the following awkward",
  [Char]
"   way to check a character for whitespace.",
  [Char]
"   Note: String.trim exists in the core libraries since Ocaml 4.00. *)",
  [Char]
"let isWhiteSpace (c: char) : bool = String.trim (String.make 1 c) = \"\"",
  [Char]
"",
  [Char]
"(* this render function is written for C-style languages, you may want to change it *)",
  [Char]
"let render (s : string) : doc = fun buf i -> ",
  [Char]
"    (* invariant: last char of the buffer is never whitespace *)",
  [Char]
"    let n = Buffer.length buf in",
  [Char]
"    let last = if n = 0 then None else Some (Buffer.nth buf (n-1)) in",
  [Char]
"    let newindent = match s with",
  [Char]
"        \"{\" -> i + indent_width",
  [Char]
"      | \"}\" -> i - indent_width",
  [Char]
"      | _ -> i in",
  [Char]
"    let whitespace = match last with",
  [Char]
"        None -> \"\" ",
  [Char]
"      | Some '}' -> (match s with",
  [Char]
"            \";\" -> \"\"",
  [Char]
"          | _ -> indent newindent)",
  [Char]
"      | (Some '{') | (Some ';') -> if s = \"}\" then indent newindent else indent i",
  [Char]
"      | (Some '[') | (Some '(') -> \"\"",
  [Char]
"      | Some c -> if isWhiteSpace c then \"\" else (match s with",
  [Char]
"             \";\" | \",\" | \")\" | \"]\" -> \"\"",
  [Char]
"           | \"{\" -> indent i",
  [Char]
"           | \"}\" -> indent newindent",
  [Char]
"           | _ -> if String.trim s = \"\" then \"\" else \" \") in",
  [Char]
"    Buffer.add_string buf whitespace;",
  [Char]
"    Buffer.add_string buf s;",
  [Char]
"    newindent",
  [Char]
"",
  [Char]
"let emptyDoc : doc = fun buf i -> i",
  [Char]
"",
  [Char]
"let concatD (ds : doc list) : doc = fun buf i -> ",
  [Char]
"    List.fold_left (fun accIndent elemDoc -> elemDoc buf accIndent) (emptyDoc buf i) ds",
  [Char]
"",
  [Char]
"let parenth (d:doc) : doc = concatD [render \"(\"; d; render \")\"]",
  [Char]
"",
  [Char]
"let prPrec (i:int) (j:int) (d:doc) : doc = if j<i then parenth d else d",
  [Char]
""
  ]

charRule :: CF -> String
charRule :: CF -> [Char]
charRule CF
cf = [[Char]] -> [Char]
unlines
  [ [Char]
"let prtChar (_:int) (c:char) : doc = render (\"'\" ^ Char.escaped c ^ \"'\")"
  , CF -> Cat -> [Char]
ifList' CF
cf ([Char] -> Cat
TokenCat [Char]
catChar)
  , [Char]
""
  ]

integerRule :: CF -> String
integerRule :: CF -> [Char]
integerRule CF
cf = [[Char]] -> [Char]
unlines
  [ [Char]
"let prtInt (_:int) (i:int) : doc = render (string_of_int i)"
  , CF -> Cat -> [Char]
ifList' CF
cf ([Char] -> Cat
TokenCat [Char]
catInteger)
  , [Char]
""
  ]

doubleRule :: CF -> String
doubleRule :: CF -> [Char]
doubleRule CF
cf = [[Char]] -> [Char]
unlines
  [ [Char]
"let prtFloat (_:int) (f:float) : doc = render (sprintf \"%.15g\" f)"
  , CF -> Cat -> [Char]
ifList' CF
cf ([Char] -> Cat
TokenCat [Char]
catDouble)
  , [Char]
""
  ]

stringRule :: CF -> String
stringRule :: CF -> [Char]
stringRule CF
cf = [[Char]] -> [Char]
unlines
  [ [Char]
"let prtString (_:int) (s:string) : doc = render (\"\\\"\" ^ String.escaped s ^ \"\\\"\")"
  , CF -> Cat -> [Char]
ifList' CF
cf ([Char] -> Cat
TokenCat [Char]
catString)
  , [Char]
""
  ]

identRule :: ModuleName -> CF -> String
identRule :: [Char] -> CF -> [Char]
identRule [Char]
absMod CF
cf = [Char] -> CF -> [Char] -> [Char]
ownPrintRule [Char]
absMod CF
cf [Char]
catIdent

ownPrintRule :: ModuleName -> CF -> TokenCat -> String
ownPrintRule :: [Char] -> CF -> [Char] -> [Char]
ownPrintRule [Char]
absMod CF
cf [Char]
own = [[Char]] -> [Char]
unlines
  [ [Char]
"let" [Char] -> [Char] -> [Char]
+++ Cat -> [Char]
prtFun ([Char] -> Cat
TokenCat [Char]
own) [Char] -> [Char] -> [Char]
+++ [Char]
"_ (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
absMod [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
own [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
posn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") : doc = render i"
  , CF -> Cat -> [Char]
ifList' CF
cf ([Char] -> Cat
TokenCat [Char]
own)
  ]
 where
   posn :: [Char]
posn = if CF -> [Char] -> Bool
forall f. CFG f -> [Char] -> Bool
isPositionCat CF
cf [Char]
own then [Char]
" (_,i)" else [Char]
" i"

-- copy and paste from CFtoTemplate

rules :: ModuleName -> CF -> String
rules :: [Char] -> CF -> [Char]
rules [Char]
absMod CF
cf = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
mutualDefs ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
  (Data -> [Char]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Cat
s,[([Char], [Cat])]
xs) -> [Char]
-> Cat
-> [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))]
-> [Char]
case_fun [Char]
absMod Cat
s ((([Char], [Cat])
 -> (([Char], [[Char]]), (Cat, [Either Cat [Char]])))
-> [([Char], [Cat])]
-> [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Cat]) -> (([Char], [[Char]]), (Cat, [Either Cat [Char]]))
toArgs [([Char], [Cat])]
xs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CF -> Cat -> [Char]
ifList CF
cf Cat
s) ([Data] -> [[Char]]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [Data]
cf2data CF
cf
 where
   reserved :: [[Char]]
reserved = [Char]
"i"[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[Char]
"e"[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
reservedOCaml
   toArgs :: ([Char], [Cat]) -> (([Char], [[Char]]), (Cat, [Either Cat [Char]]))
toArgs ([Char]
cons,[Cat]
args) = (([Char]
cons, [[Char]] -> NameStyle -> [[Char]] -> [[Char]]
mkNames [[Char]]
reserved NameStyle
LowerCase ((Cat -> [Char]) -> [Cat] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> [Char]
var [Cat]
args)), [Char] -> (Cat, [Either Cat [Char]])
ruleOf [Char]
cons)
   var :: Cat -> [Char]
var (ListCat Cat
c)  = Cat -> [Char]
var Cat
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"s"
   var (Cat [Char]
"Ident")   = [Char]
"id"
   var (Cat [Char]
"Integer") = [Char]
"n"
   var (Cat [Char]
"String")  = [Char]
"str"
   var (Cat [Char]
"Char")    = [Char]
"c"
   var (Cat [Char]
"Double")  = [Char]
"d"
   var Cat
xs   = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Cat -> [Char]
catToStr Cat
xs)
   ruleOf :: [Char] -> (Cat, [Either Cat [Char]])
ruleOf [Char]
s = Maybe (Cat, [Either Cat [Char]]) -> (Cat, [Either Cat [Char]])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Cat, [Either Cat [Char]]) -> (Cat, [Either Cat [Char]]))
-> Maybe (Cat, [Either Cat [Char]]) -> (Cat, [Either Cat [Char]])
forall a b. (a -> b) -> a -> b
$ RFun -> [Rul RFun] -> Maybe (Cat, [Either Cat [Char]])
forall f. Eq f => f -> [Rul f] -> Maybe (Cat, [Either Cat [Char]])
lookupRule ([Char] -> RFun
forall a. a -> WithPosition a
noPosition [Char]
s) (CF -> [Rul RFun]
forall function. CFG function -> [Rul function]
cfgRules CF
cf)

-- case_fun :: Cat -> [(Constructor,Rule)] -> String
case_fun
  :: String
  -> Cat
  -> [((String, [String]), (Cat, [Either Cat String]))]
  -> String
case_fun :: [Char]
-> Cat
-> [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))]
-> [Char]
case_fun [Char]
absMod Cat
cat [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))]
xs = [[Char]] -> [Char]
unlines [
--  "instance Print" +++ cat +++ "where",
  Cat -> [Char]
prtFun Cat
cat [Char] -> [Char] -> [Char]
+++[Char]
"(i:int)" [Char] -> [Char] -> [Char]
+++ [Char]
"(e : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Cat -> [Char]
fixTypeQual [Char]
absMod Cat
cat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") : doc = match e with",
  [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
insertBar ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ((([Char], [[Char]]), (Cat, [Either Cat [Char]])) -> [Char])
-> [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (([Char]
c,[[Char]]
xx),(Cat, [Either Cat [Char]])
r) ->
    [Char]
"   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
absMod [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> [Char] -> [Char]
+++ [[Char]] -> [Char]
mkTuple [[Char]]
xx [Char] -> [Char] -> [Char]
+++ [Char]
"->" [Char] -> [Char] -> [Char]
+++
    [Char]
"prPrec i" [Char] -> [Char] -> [Char]
+++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (Cat -> Integer
precCat ((Cat, [Either Cat [Char]]) -> Cat
forall a b. (a, b) -> a
fst (Cat, [Either Cat [Char]])
r)) [Char] -> [Char] -> [Char]
+++ [[Char]] -> [Either Cat [Char]] -> [Char]
mkRhs [[Char]]
xx ((Cat, [Either Cat [Char]]) -> [Either Cat [Char]]
forall a b. (a, b) -> b
snd (Cat, [Either Cat [Char]])
r)) [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))]
xs
  ]

-- ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where
--   nil cat  = ["    []    -> " ++ mkRhs [] its |
--                             Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]
--   one cat  = ["  | [x]   -> " ++ mkRhs ["x"] its |
--                             Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]
--   cons cat = ["  | x::xs -> " ++ mkRhs ["x","xs"] its |
--                             Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]
--   mkListRule [] = ""
--   mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs

ifList :: CF -> Cat -> String
ifList :: CF -> Cat -> [Char]
ifList = Doc -> CF -> Cat -> [Char]
ifListP Doc
"and"

ifList' :: CF -> Cat -> String
ifList' :: CF -> Cat -> [Char]
ifList' = Doc -> CF -> Cat -> [Char]
ifListP Doc
"let rec"

ifListP :: Doc -> CF -> Cat -> String
ifListP :: Doc -> CF -> Cat -> [Char]
ifListP Doc
letrec CF
cf Cat
cat
  | [Rul RFun] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Rul RFun]
rules = [Char]
""
  | Bool
otherwise  = Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ case [Doc]
cases of
    []         -> Doc
empty  -- IMPOSSIBLE CASE when (rules /= [])
    Doc
first:[Doc]
rest -> [Doc] -> Doc
vcat
        [ Doc
letrec Doc -> Doc -> Doc
<+> Doc
"prt" Doc -> Doc -> Doc
<> [Char] -> Doc
text (Cat -> [Char]
fixTypeUpper Cat
cat)  Doc -> Doc -> Doc
<> Doc
"ListBNFC i es : doc = match (i, es) with"
        , Int -> Doc -> Doc
nest Int
4 Doc
first
        , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc
"|" Doc -> Doc -> Doc
<+>) [Doc]
rest)
        ]
  where
    rules :: [Rul RFun]
rules = (Rul RFun -> Rul RFun -> Ordering) -> [Rul RFun] -> [Rul RFun]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Rul RFun -> Rul RFun -> Ordering
forall f. IsFun f => Rul f -> Rul f -> Ordering
compareRules ([Rul RFun] -> [Rul RFun]) -> [Rul RFun] -> [Rul RFun]
forall a b. (a -> b) -> a -> b
$ CF -> Cat -> [Rul RFun]
rulesForNormalizedCat CF
cf (Cat -> Cat
ListCat Cat
cat)
    cases :: [Doc]
cases = [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ Doc
"(_,[]) -> (concatD [])" | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Rul RFun -> Bool) -> [Rul RFun] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Rul RFun -> Bool
forall a. IsFun a => a -> Bool
isNilFun [Rul RFun]
rules ]
            -- Andreas, 2021-09-22, issue #386
            -- If the list is @nonempty@ according to the grammar, still add a nil case.
            -- In the AST it is simply a list, and the AST could be created
            -- by other means than by parsing.
      , [ Doc
d | Rul RFun
r <- [Rul RFun]
rules, let d :: Doc
d = Integer -> Rul RFun -> Doc
mkPrtListCase Integer
minPrec Rul RFun
r, Bool -> Bool
not (Doc -> Bool
isEmpty Doc
d) ]
      ]
    -- Andreas, 2021-09-22, issue #384:
    -- The minimum precedence of a rule lhs category in the rules set.
    -- This is considered the default precedence; used to make the printing function total.
    minPrec :: Integer
minPrec = [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ (Rul RFun -> Integer) -> [Rul RFun] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Rul RFun -> Integer
forall f. Rul f -> Integer
precRule [Rul RFun]
rules

-- | Pattern match on the list constructor and the coercion level
--
-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
-- (_,[]) -> (concatD [])
--
-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "Foo")] Parsable)
-- (_,[x]) -> (concatD [prtFoo 0 x])
--
-- >>> mkPrtListCase 0 (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
-- (_,x::xs) -> (concatD [prtFoo 0 x ; prtFooListBNFC 0 xs])
--
-- >>> mkPrtListCase 0 (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
-- (2,[]) -> (concatD [])
--
-- >>> mkPrtListCase 0 (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
-- (2,[x]) -> (concatD [prtFoo 2 x])
--
-- >>> mkPrtListCase 2 (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
-- (_,x::xs) -> (concatD [prtFoo 2 x ; prtFooListBNFC 2 xs])
--
mkPrtListCase
  :: Integer -- ^ The lowest precedence of a lhs in a list rule.  Default: 0.
  -> Rule    -- ^ The list rule.
  -> Doc
mkPrtListCase :: Integer -> Rul RFun -> Doc
mkPrtListCase Integer
minPrec (Rule RFun
f (WithPosition Position
_ (ListCat Cat
c)) [Either Cat [Char]]
rhs InternalRule
_)
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isNilFun RFun
f  = Doc -> Doc
parens (Doc
precPattern Doc -> Doc -> Doc
<> Doc
"," Doc -> Doc -> Doc
<> Doc
"[]") Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> Doc
body
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isOneFun RFun
f  = Doc -> Doc
parens (Doc
precPattern Doc -> Doc -> Doc
<> Doc
"," Doc -> Doc -> Doc
<> Doc
"[x]") Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> Doc
body
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun RFun
f = Doc -> Doc
parens (Doc
precPattern Doc -> Doc -> Doc
<> Doc
"," Doc -> Doc -> Doc
<>Doc
"x::xs") Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> Doc
body
  | Bool
otherwise = Doc
empty -- (++) constructor
  where
    precPattern :: Doc
precPattern = if Integer
p Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
minPrec then Doc
"_" else Integer -> Doc
integer Integer
p
    p :: Integer
p = Cat -> Integer
precCat Cat
c
    body :: Doc
body = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Either Cat [Char]] -> [Char]
mkRhs [[Char]
"x", [Char]
"xs"] [Either Cat [Char]]
rhs
mkPrtListCase Integer
_ Rul RFun
_ = [Char] -> Doc
forall a. HasCallStack => [Char] -> a
error [Char]
"mkPrtListCase undefined for non-list categories"

mkRhs :: [String] -> [Either Cat String] -> [Char]
mkRhs :: [[Char]] -> [Either Cat [Char]] -> [Char]
mkRhs [[Char]]
args [Either Cat [Char]]
its =
  [Char]
"(concatD [" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
";" ([[Char]] -> [Either Cat [Char]] -> [[Char]]
mk [[Char]]
args [Either Cat [Char]]
its)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"])"
 where
  mk :: [[Char]] -> [Either Cat [Char]] -> [[Char]]
mk ([Char]
arg:[[Char]]
args) (Left Cat
c : [Either Cat [Char]]
items)  = (Cat -> [Char]
prt Cat
c [Char] -> [Char] -> [Char]
+++ [Char]
arg)        [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [Either Cat [Char]] -> [[Char]]
mk [[Char]]
args [Either Cat [Char]]
items
  mk [[Char]]
args       (Right [Char]
s : [Either Cat [Char]]
items) = ([Char]
"render " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
mkEsc [Char]
s) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [Either Cat [Char]] -> [[Char]]
mk [[Char]]
args [Either Cat [Char]]
items
  mk [[Char]]
_ [Either Cat [Char]]
_ = []
  prt :: Cat -> [Char]
prt Cat
c = Cat -> [Char]
prtFun Cat
c [Char] -> [Char] -> [Char]
+++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (Cat -> Integer
precCat Cat
c)

prtFun :: Cat -> String
prtFun :: Cat -> [Char]
prtFun (ListCat Cat
c) = Cat -> [Char]
prtFun Cat
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"ListBNFC"
prtFun Cat
c = [Char]
"prt" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Cat -> [Char]
fixTypeUpper (Cat -> Cat
normCat Cat
c)