{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{-
    BNF Converter: C Pretty Printer printer
    Copyright (C) 2004  Author:  Michael Pellauer

    Description   : This module generates the C Pretty Printer.
                    It also generates the "show" method for
                    printing an abstract syntax tree.

                    The generated files use the Visitor design pattern.

    Author        : Michael Pellauer
    Created       : 10 August, 2003
    Modified      : 3 September, 2003
                    * Added resizable buffers
-}

module BNFC.Backend.C.CFtoCPrinter (cf2CPrinter) where

import Prelude hiding ((<>))

import Data.Bifunctor ( second )
import Data.Char      ( toLower )
import Data.Either    ( lefts )
import Data.Foldable  ( toList )
import Data.List      ( nub )

import BNFC.CF
import BNFC.PrettyPrint
import BNFC.Utils     ( (+++), uniqOn, unless, unlessNull )

import BNFC.Backend.Common
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.Common.StrUtils (renderCharOrString)

-- | Produces (.h file, .c file).

cf2CPrinter :: CF -> (String, String)
cf2CPrinter :: CF -> (TokenCat, TokenCat)
cf2CPrinter CF
cf = (CF -> [(Cat, [Rul RFun])] -> TokenCat
mkHFile CF
cf [(Cat, [Rul RFun])]
groups, CF -> [(Cat, [Rul RFun])] -> TokenCat
mkCFile CF
cf [(Cat, [Rul RFun])]
groups)
 where
    groups :: [(Cat, [Rul RFun])]
groups = [(Cat, [Rul RFun])] -> [(Cat, [Rul RFun])]
fixCoercions ([(Cat, [Rul RFun])] -> [(Cat, [Rul RFun])])
-> [(Cat, [Rul RFun])] -> [(Cat, [Rul RFun])]
forall a b. (a -> b) -> a -> b
$ [(Cat, [Rul RFun])] -> [(Cat, [Rul RFun])]
forall {a}. [(a, [Rul RFun])] -> [(a, [Rul RFun])]
filterOutDefs ([(Cat, [Rul RFun])] -> [(Cat, [Rul RFun])])
-> [(Cat, [Rul RFun])] -> [(Cat, [Rul RFun])]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rul RFun])]
ruleGroupsInternals CF
cf
    filterOutDefs :: [(a, [Rul RFun])] -> [(a, [Rul RFun])]
filterOutDefs = ((a, [Rul RFun]) -> (a, [Rul RFun]))
-> [(a, [Rul RFun])] -> [(a, [Rul RFun])]
forall a b. (a -> b) -> [a] -> [b]
map (((a, [Rul RFun]) -> (a, [Rul RFun]))
 -> [(a, [Rul RFun])] -> [(a, [Rul RFun])])
-> ((a, [Rul RFun]) -> (a, [Rul RFun]))
-> [(a, [Rul RFun])]
-> [(a, [Rul RFun])]
forall a b. (a -> b) -> a -> b
$ ([Rul RFun] -> [Rul RFun]) -> (a, [Rul RFun]) -> (a, [Rul RFun])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (([Rul RFun] -> [Rul RFun]) -> (a, [Rul RFun]) -> (a, [Rul RFun]))
-> ([Rul RFun] -> [Rul RFun]) -> (a, [Rul RFun]) -> (a, [Rul RFun])
forall a b. (a -> b) -> a -> b
$ (Rul RFun -> Bool) -> [Rul RFun] -> [Rul RFun]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Rul RFun -> Bool) -> [Rul RFun] -> [Rul RFun])
-> (Rul RFun -> Bool) -> [Rul RFun] -> [Rul RFun]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (Rul RFun -> Bool) -> Rul RFun -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RFun -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule (RFun -> Bool) -> (Rul RFun -> RFun) -> Rul RFun -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rul RFun -> RFun
forall function. Rul function -> function
funRule

{- **** Header (.h) File Methods **** -}

-- | Make the Header File.

mkHFile :: CF -> [(Cat,[Rule])] -> String
mkHFile :: CF -> [(Cat, [Rul RFun])] -> TokenCat
mkHFile CF
cf [(Cat, [Rul RFun])]
groups = [TokenCat] -> TokenCat
unlines
 [
  TokenCat
header,
  (Cat -> TokenCat) -> [Cat] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> TokenCat
prPrints [Cat]
eps,
  ((Cat, [Rul RFun]) -> TokenCat) -> [(Cat, [Rul RFun])] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rul RFun]) -> TokenCat
prPrintDataH [(Cat, [Rul RFun])]
groups,
  (Cat -> TokenCat) -> [Cat] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> TokenCat
prShows [Cat]
eps,
  ((Cat, [Rul RFun]) -> TokenCat) -> [(Cat, [Rul RFun])] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rul RFun]) -> TokenCat
prShowDataH [(Cat, [Rul RFun])]
groups,
  TokenCat
footer
 ]
 where
  eps :: [Cat]
eps = [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat]) -> (List1 Cat -> [Cat]) -> List1 Cat -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> Cat) -> [Cat] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat ([Cat] -> [Cat]) -> (List1 Cat -> [Cat]) -> List1 Cat -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Cat -> [Cat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (List1 Cat -> [Cat]) -> List1 Cat -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> List1 Cat
forall f. CFG f -> List1 Cat
allEntryPoints CF
cf
  prPrints :: Cat -> TokenCat
prPrints Cat
s | Cat -> Cat
normCat Cat
s Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
s = TokenCat
"char *print" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
s' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
s' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" p);\n"
    where
      s' :: TokenCat
s' = Cat -> TokenCat
identCat Cat
s
  prPrints Cat
_ = TokenCat
""
  prShows :: Cat -> TokenCat
prShows Cat
s | Cat -> Cat
normCat Cat
s Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
s = TokenCat
"char *show" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
s' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
s' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" p);\n"
    where
      s' :: TokenCat
s' = Cat -> TokenCat
identCat Cat
s
  prShows Cat
_ = TokenCat
""
  header :: TokenCat
header = [TokenCat] -> TokenCat
unlines
   [
    TokenCat
"#ifndef PRINTER_HEADER",
    TokenCat
"#define PRINTER_HEADER",
    TokenCat
"",
    TokenCat
"#include \"Absyn.h\"",
    TokenCat
"",
    TokenCat
"/* Certain applications may improve performance by changing the buffer size */",
    TokenCat
"#define BUFFER_INITIAL 2048",
    TokenCat
"/* You may wish to change _L_PAREN or _R_PAREN */",
    TokenCat
"#define _L_PAREN '('",
    TokenCat
"#define _R_PAREN ')'",
    TokenCat
"",
    TokenCat
"/* The following are simple heuristics for rendering terminals */",
    TokenCat
"/* You may wish to change them */",
    TokenCat
"void renderCC(Char c);",
    TokenCat
"void renderCS(String s);",
    TokenCat
"void indent(void);",
    TokenCat
"void backup(void);",
    TokenCat
"void onEmptyLine(void);",
    TokenCat
"void removeTrailingSpaces(void);",
    TokenCat
"void removeTrailingWhitespace(void);",
    TokenCat
""
   ]
  footer :: TokenCat
footer = [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$
   [TokenCat
"void pp" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
t TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(String s, int i);" | TokenCat
t <- CF -> [TokenCat]
forall f. CFG f -> [TokenCat]
tokenNames CF
cf]
    [TokenCat] -> [TokenCat] -> [TokenCat]
forall a. [a] -> [a] -> [a]
++
   [TokenCat
"void sh" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
t TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(String s);" | TokenCat
t <- CF -> [TokenCat]
forall f. CFG f -> [TokenCat]
tokenNames CF
cf]
    [TokenCat] -> [TokenCat] -> [TokenCat]
forall a. [a] -> [a] -> [a]
++
   [
    TokenCat
"void ppInteger(Integer n, int i);",
    TokenCat
"void ppDouble(Double d, int i);",
    TokenCat
"void ppChar(Char c, int i);",
    TokenCat
"void ppString(String s, int i);",
    TokenCat
"void ppIdent(String s, int i);",
    TokenCat
"void shInteger(Integer n);",
    TokenCat
"void shDouble(Double d);",
    TokenCat
"void shChar(Char c);",
    TokenCat
"void shString(String s);",
    TokenCat
"void shIdent(String s);",
    TokenCat
"void bufAppendS(const char *s);",
    TokenCat
"void bufAppendC(const char c);",
    TokenCat
"void bufReset(void);",
    TokenCat
"void resizeBuffer(void);",
    TokenCat
"",
    TokenCat
"#endif"
   ]

-- | Prints all the required method names and their parameters.

prPrintDataH :: (Cat, [Rule]) -> String
prPrintDataH :: (Cat, [Rul RFun]) -> TokenCat
prPrintDataH (Cat
cat, [Rul RFun]
_) = [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [TokenCat
"void pp", TokenCat
cl, TokenCat
"(", TokenCat
cl, TokenCat
" p, int i);\n"]
  where
   cl :: TokenCat
cl = Cat -> TokenCat
identCat (Cat -> Cat
normCat Cat
cat)

-- | Prints all the required method names and their parameters.

prShowDataH :: (Cat, [Rule]) -> String
prShowDataH :: (Cat, [Rul RFun]) -> TokenCat
prShowDataH (Cat
cat, [Rul RFun]
_) = [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [TokenCat
"void sh", TokenCat
cl, TokenCat
"(", TokenCat
cl, TokenCat
" p);\n"]
  where
   cl :: TokenCat
cl = Cat -> TokenCat
identCat (Cat -> Cat
normCat Cat
cat)

{- **** Implementation (.C) File Methods **** -}

-- | This makes the .C file by a similar method.

mkCFile :: CF -> [(Cat,[Rule])] -> String
mkCFile :: CF -> [(Cat, [Rul RFun])] -> TokenCat
mkCFile CF
cf [(Cat, [Rul RFun])]
groups = [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
   [
    TokenCat
header,
    TokenCat
prRender,
    (Cat -> TokenCat) -> [Cat] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> TokenCat
prPrintFun [Cat]
eps,
    (Cat -> TokenCat) -> [Cat] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> TokenCat
prShowFun [Cat]
eps,
    ((Cat, [Rul RFun]) -> TokenCat) -> [(Cat, [Rul RFun])] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rul RFun]) -> TokenCat
prPrintData [(Cat, [Rul RFun])]
groups,
    TokenCat
printBasics,
    TokenCat
printTokens,
    ((Cat, [Rul RFun]) -> TokenCat) -> [(Cat, [Rul RFun])] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rul RFun]) -> TokenCat
prShowData [(Cat, [Rul RFun])]
groups,
    TokenCat
showBasics,
    TokenCat
showTokens,
    TokenCat
footer
   ]
  where
    eps :: [Cat]
eps = [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat]) -> (List1 Cat -> [Cat]) -> List1 Cat -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> Cat) -> [Cat] -> [Cat]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> Cat
normCat ([Cat] -> [Cat]) -> (List1 Cat -> [Cat]) -> List1 Cat -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 Cat -> [Cat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (List1 Cat -> [Cat]) -> List1 Cat -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> List1 Cat
forall f. CFG f -> List1 Cat
allEntryPoints CF
cf
    header :: TokenCat
header = [TokenCat] -> TokenCat
unlines
     [
      TokenCat
"/*** Pretty Printer and Abstract Syntax Viewer ***/",
      TokenCat
"",
      TokenCat
"#include <ctype.h>   /* isspace */",
      TokenCat
"#include <stddef.h>  /* size_t */",
      TokenCat
"#include <stdio.h>",
      TokenCat
"#include <string.h>",
      TokenCat
"#include <stdlib.h>",
      TokenCat
"#include \"Printer.h\"",
      TokenCat
"",
      TokenCat
"#define INDENT_WIDTH 2",
      TokenCat
"",
      TokenCat
"int _n_;",
      TokenCat
"char *buf_;",
      TokenCat
"size_t cur_;",
      TokenCat
"size_t buf_size;",
      TokenCat
""
     ]
    printBasics :: TokenCat
printBasics = [TokenCat] -> TokenCat
unlines
     [
      TokenCat
"void ppInteger(Integer n, int i)",
      TokenCat
"{",
      -- https://stackoverflow.com/questions/10536207/ansi-c-maximum-number-of-characters-printing-a-decimal-int
      -- A buffer of 20 characters is sufficient to print the decimal representation
      -- of a 64bit integer.  Might not be needed here, but does not hurt.
      TokenCat
"  char tmp[20];",
      TokenCat
"  sprintf(tmp, \"%d\", n);",
      TokenCat
"  renderS(tmp);",
      TokenCat
"}",
      TokenCat
"void ppDouble(Double d, int i)",
      TokenCat
"{",
      -- https://stackoverflow.com/questions/1701055/what-is-the-maximum-length-in-chars-needed-to-represent-any-double-value
      -- Recommended buffer size is 24 for doubles (IEEE-754):
      -- (*) 17 digits for the decimal representation of the integral part
      -- (*)  5 digits for the exponent
      TokenCat
"  char tmp[24];",
      TokenCat
"  sprintf(tmp, \"%.15g\", d);",
      TokenCat
"  renderS(tmp);",
      TokenCat
"}",
      TokenCat
"void ppChar(Char c, int i)",
      TokenCat
"{",
      TokenCat
"  char tmp[4];",
      TokenCat
"  sprintf(tmp, \"'%c'\", c);",
      TokenCat
"  renderS(tmp);",
      TokenCat
"}",
      TokenCat
"void ppString(String s, int i)",
      TokenCat
"{",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"  bufAppendS(s);",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"  bufAppendC(' ');",
      TokenCat
"}",
      TokenCat
"void ppIdent(String s, int i)",
      TokenCat
"{",
      TokenCat
"  renderS(s);",
      TokenCat
"}",
      TokenCat
""
     ]
    printTokens :: TokenCat
printTokens = [TokenCat] -> TokenCat
unlines
     [[TokenCat] -> TokenCat
unlines [
      TokenCat
"void pp" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
t TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(String s, int i)",
      TokenCat
"{",
      TokenCat
"  renderS(s);",
      TokenCat
"}",
      TokenCat
""
      ] | TokenCat
t <- CF -> [TokenCat]
forall f. CFG f -> [TokenCat]
tokenNames CF
cf
     ]
    showBasics :: TokenCat
showBasics = [TokenCat] -> TokenCat
unlines
     [
      TokenCat
"void shInteger(Integer i)",
      TokenCat
"{",
      TokenCat
"  char tmp[20];",
      TokenCat
"  sprintf(tmp, \"%d\", i);",
      TokenCat
"  bufAppendS(tmp);",
      TokenCat
"}",
      TokenCat
"void shDouble(Double d)",
      TokenCat
"{",
      TokenCat
"  char tmp[24];",
      TokenCat
"  sprintf(tmp, \"%.15g\", d);",
      TokenCat
"  bufAppendS(tmp);",
      TokenCat
"}",
      TokenCat
"void shChar(Char c)",
      TokenCat
"{",
      TokenCat
"  bufAppendC('\\'');",
      TokenCat
"  bufAppendC(c);",
      TokenCat
"  bufAppendC('\\'');",
      TokenCat
"}",
      TokenCat
"void shString(String s)",
      TokenCat
"{",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"  bufAppendS(s);",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"}",
      TokenCat
"void shIdent(String s)",
      TokenCat
"{",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"  bufAppendS(s);",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"}",
      TokenCat
""
     ]
    showTokens :: TokenCat
showTokens = [TokenCat] -> TokenCat
unlines
     [[TokenCat] -> TokenCat
unlines [
      TokenCat
"void sh" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
t TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(String s)",
      TokenCat
"{",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"  bufAppendS(s);",
      TokenCat
"  bufAppendC('\\\"');",
      TokenCat
"}",
      TokenCat
""
      ] | TokenCat
t <- CF -> [TokenCat]
forall f. CFG f -> [TokenCat]
tokenNames CF
cf
     ]
    footer :: TokenCat
footer = [TokenCat] -> TokenCat
unlines
     [
      TokenCat
"void bufAppendS(const char *s)",
      TokenCat
"{",
      TokenCat
"  size_t len = strlen(s);",
      TokenCat
"  size_t n;",
      TokenCat
"  while (cur_ + len >= buf_size)",
      TokenCat
"  {",
      TokenCat
"    buf_size *= 2; /* Double the buffer size */",
      TokenCat
"    resizeBuffer();",
      TokenCat
"  }",
      TokenCat
"  for(n = 0; n < len; n++)",
      TokenCat
"  {",
      TokenCat
"    buf_[cur_ + n] = s[n];",
      TokenCat
"  }",
      TokenCat
"  cur_ += len;",
      TokenCat
"  buf_[cur_] = 0;",
      TokenCat
"}",
      TokenCat
"void bufAppendC(const char c)",
      TokenCat
"{",
      TokenCat
"  if (cur_ + 1 >= buf_size)",
      TokenCat
"  {",
      TokenCat
"    buf_size *= 2; /* Double the buffer size */",
      TokenCat
"    resizeBuffer();",
      TokenCat
"  }",
      TokenCat
"  buf_[cur_] = c;",
      TokenCat
"  cur_++;",
      TokenCat
"  buf_[cur_] = 0;",
      TokenCat
"}",
      TokenCat
"void bufReset(void)",
      TokenCat
"{",
      TokenCat
"  cur_ = 0;",
      TokenCat
"  buf_size = BUFFER_INITIAL;",
      TokenCat
"  resizeBuffer();",
      TokenCat
"  memset(buf_, 0, buf_size);",
      TokenCat
"}",
      TokenCat
"void resizeBuffer(void)",
      TokenCat
"{",
      TokenCat
"  char *temp = (char *) malloc(buf_size);",
      TokenCat
"  if (!temp)",
      TokenCat
"  {",
      TokenCat
"    fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",
      TokenCat
"    exit(1);",
      TokenCat
"  }",
      TokenCat
"  if (buf_)",
      TokenCat
"  {",
      TokenCat
"    strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */",
      TokenCat
"    free(buf_);",
      TokenCat
"  }",
      TokenCat
"  buf_ = temp;",
      TokenCat
"}",
      TokenCat
"char *buf_;",
      TokenCat
"size_t cur_, buf_size;",
      TokenCat
""
     ]


{- **** Pretty Printer Methods **** -}

-- | An entry point to the printer.

prPrintFun :: Cat -> String
prPrintFun :: Cat -> TokenCat
prPrintFun Cat
ep | Cat -> Cat
normCat Cat
ep Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
ep = [TokenCat] -> TokenCat
unlines
  [
   TokenCat
"char *print" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
ep' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
ep' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" p)",
   TokenCat
"{",
   TokenCat
"  _n_ = 0;",
   TokenCat
"  bufReset();",
   TokenCat
"  pp" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
ep' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(p, 0);",
   TokenCat
"  return buf_;",
   TokenCat
"}"
  ]
 where
  ep' :: TokenCat
ep' = Cat -> TokenCat
identCat Cat
ep
prPrintFun Cat
_ = TokenCat
""

-- Generates methods for the Pretty Printer

prPrintData :: (Cat, [Rule]) -> String
prPrintData :: (Cat, [Rul RFun]) -> TokenCat
prPrintData (Cat
cat, [Rul RFun]
rules)
  | Cat -> Bool
isList Cat
cat = [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ TokenCat
"void pp" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"("TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
+++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
", int i)"
      , TokenCat
"{"
      , TokenCat
"  if (" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"== 0)"
      , TokenCat
"  { /* nil */"
      ]
    , [Doc] -> ([Doc] -> [TokenCat]) -> [TokenCat]
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (((Integer, Rul RFun) -> Bool) -> [Doc]
swRules (Integer, Rul RFun) -> Bool
forall a. IsFun a => a -> Bool
isNilFun) (([Doc] -> [TokenCat]) -> [TokenCat])
-> ([Doc] -> [TokenCat]) -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ \ [Doc]
docs ->
      [ Doc -> TokenCat
render (Doc -> TokenCat) -> Doc -> TokenCat
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat [Doc]
docs ]
    , [ TokenCat
"  }" ]
    , [Doc] -> ([Doc] -> [TokenCat]) -> [TokenCat]
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (((Integer, Rul RFun) -> Bool) -> [Doc]
swRules (Integer, Rul RFun) -> Bool
forall a. IsFun a => a -> Bool
isOneFun) (([Doc] -> [TokenCat]) -> [TokenCat])
-> ([Doc] -> [TokenCat]) -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ \ [Doc]
docs ->
      [ TokenCat
"  else if (" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
pre TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"_ == 0)"
      , TokenCat
"  { /* last */"
      , Doc -> TokenCat
render (Doc -> TokenCat) -> Doc -> TokenCat
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat [Doc]
docs
      , TokenCat
"  }"
      ]
    , [Doc] -> ([Doc] -> [TokenCat]) -> [TokenCat]
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (((Integer, Rul RFun) -> Bool) -> [Doc]
swRules (Integer, Rul RFun) -> Bool
forall a. IsFun a => a -> Bool
isConsFun) (([Doc] -> [TokenCat]) -> [TokenCat])
-> ([Doc] -> [TokenCat]) -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ \ [Doc]
docs ->
      [ TokenCat
"  else"
      , TokenCat
"  { /* cons */"
      , Doc -> TokenCat
render (Doc -> TokenCat) -> Doc -> TokenCat
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat [Doc]
docs
      , TokenCat
"  }"
      ]
    , [ TokenCat
"}"
      , TokenCat
""
      ]
    ]
  | Bool
otherwise = [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ TokenCat
"void pp" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" p, int _i_)"
      , TokenCat
"{"
      , TokenCat
"  switch(p->kind)"
      , TokenCat
"  {"
      ]
    , (Rul RFun -> [TokenCat]) -> [Rul RFun] -> [TokenCat]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Rul RFun -> [TokenCat]
prPrintRule [Rul RFun]
rules
    , [ TokenCat
"  default:"
      , TokenCat
"    fprintf(stderr, \"Error: bad kind field when printing " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
catToStr Cat
cat TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"!\\n\");"
      , TokenCat
"    exit(1);"
      , TokenCat
"  }"
      , TokenCat
"}"
      , TokenCat
""
      ]
    ]
 where
   cl :: TokenCat
cl          = Cat -> TokenCat
identCat (Cat -> Cat
normCat Cat
cat)
   vname :: TokenCat
vname       = (Char -> Char) -> TokenCat -> TokenCat
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower TokenCat
cl
   pre :: TokenCat
pre         = TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"->"
   prules :: [(Integer, Rul RFun)]
prules      = [Rul RFun] -> [(Integer, Rul RFun)]
sortRulesByPrecedence [Rul RFun]
rules
   swRules :: ((Integer, Rul RFun) -> Bool) -> [Doc]
swRules (Integer, Rul RFun) -> Bool
f   = Doc -> [(Integer, Doc)] -> [Doc]
switchByPrecedence Doc
"i" ([(Integer, Doc)] -> [Doc]) -> [(Integer, Doc)] -> [Doc]
forall a b. (a -> b) -> a -> b
$
                   ((Integer, Rul RFun) -> (Integer, Doc))
-> [(Integer, Rul RFun)] -> [(Integer, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((Rul RFun -> Doc) -> (Integer, Rul RFun) -> (Integer, Doc)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Rul RFun -> Doc) -> (Integer, Rul RFun) -> (Integer, Doc))
-> (Rul RFun -> Doc) -> (Integer, Rul RFun) -> (Integer, Doc)
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> (Rul RFun -> [Doc]) -> Rul RFun -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenCat -> Doc) -> [TokenCat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TokenCat -> Doc
text ([TokenCat] -> [Doc])
-> (Rul RFun -> [TokenCat]) -> Rul RFun -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenCat -> Rul RFun -> [TokenCat]
forall a. IsFun a => TokenCat -> Rul a -> [TokenCat]
prPrintRule_ TokenCat
pre) ([(Integer, Rul RFun)] -> [(Integer, Doc)])
-> [(Integer, Rul RFun)] -> [(Integer, Doc)]
forall a b. (a -> b) -> a -> b
$
                     ((Integer, Rul RFun) -> Integer)
-> [(Integer, Rul RFun)] -> [(Integer, Rul RFun)]
forall b a. Eq b => (a -> b) -> [a] -> [a]
uniqOn (Integer, Rul RFun) -> Integer
forall a b. (a, b) -> a
fst ([(Integer, Rul RFun)] -> [(Integer, Rul RFun)])
-> [(Integer, Rul RFun)] -> [(Integer, Rul RFun)]
forall a b. (a -> b) -> a -> b
$ ((Integer, Rul RFun) -> Bool)
-> [(Integer, Rul RFun)] -> [(Integer, Rul RFun)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Integer, Rul RFun) -> Bool
f [(Integer, Rul RFun)]
prules
                     -- Discard duplicates, can only handle one rule per precedence.

-- | Helper function that call the right c function (renderC or renderS) to
-- render a literal string.
--
-- >>> renderX ","
-- renderC(',')
--
-- >>> renderX "---"
-- renderS("---")

renderX :: String -> Doc
renderX :: TokenCat -> Doc
renderX TokenCat
sep' = Doc
"render" Doc -> Doc -> Doc
<> Char -> Doc
char Char
sc Doc -> Doc -> Doc
<> Doc -> Doc
parens (TokenCat -> Doc
text TokenCat
sep)
  where (Char
sc, TokenCat
sep) = TokenCat -> (Char, TokenCat)
renderCharOrString TokenCat
sep'


-- | Pretty Printer methods for a rule.

prPrintRule :: Rule -> [String]
prPrintRule :: Rul RFun -> [TokenCat]
prPrintRule r :: Rul RFun
r@(Rule RFun
fun RCat
_ SentForm
_ InternalRule
_) = Bool -> [TokenCat] -> [TokenCat]
forall m. Monoid m => Bool -> m -> m
unless (RFun -> Bool
forall a. IsFun a => a -> Bool
isCoercion RFun
fun) ([TokenCat] -> [TokenCat]) -> [TokenCat] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ TokenCat
"  case is_" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
fnm TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
":"
    , TokenCat
"    if (_i_ > " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Integer -> TokenCat
forall a. Show a => a -> TokenCat
show Integer
p TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
") renderC(_L_PAREN);"
    ]
  , (TokenCat -> TokenCat) -> [TokenCat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map (TokenCat
"    " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++) ([TokenCat] -> [TokenCat]) -> [TokenCat] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ TokenCat -> Rul RFun -> [TokenCat]
forall a. IsFun a => TokenCat -> Rul a -> [TokenCat]
prPrintRule_ TokenCat
pre Rul RFun
r
  , [ TokenCat
"    if (_i_ > " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Integer -> TokenCat
forall a. Show a => a -> TokenCat
show Integer
p TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
") renderC(_R_PAREN);"
    , TokenCat
"    break;"
    , TokenCat
""
    ]
  ]
  where
    p :: Integer
p   = Rul RFun -> Integer
forall f. Rul f -> Integer
precRule Rul RFun
r
    fnm :: TokenCat
fnm = RFun -> TokenCat
forall a. IsFun a => a -> TokenCat
funName RFun
fun
    pre :: TokenCat
pre = [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ TokenCat
"p->u.", (Char -> Char) -> TokenCat -> TokenCat
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower TokenCat
fnm, TokenCat
"_." ]

-- | Only render the rhs (items) of a rule.

prPrintRule_ :: IsFun a => String -> Rul a -> [String]
prPrintRule_ :: forall a. IsFun a => TokenCat -> Rul a -> [TokenCat]
prPrintRule_ TokenCat
pre (Rule a
_ RCat
_ SentForm
items InternalRule
_) = (Either (Cat, Doc) TokenCat -> TokenCat)
-> [Either (Cat, Doc) TokenCat] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map (TokenCat -> Either (Cat, Doc) TokenCat -> TokenCat
prPrintItem TokenCat
pre) ([Either (Cat, Doc) TokenCat] -> [TokenCat])
-> [Either (Cat, Doc) TokenCat] -> [TokenCat]
forall a b. (a -> b) -> a -> b
$ SentForm -> [Either (Cat, Doc) TokenCat]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars SentForm
items

-- | This goes on to recurse to the instance variables.

prPrintItem :: String -> Either (Cat, Doc) String -> String
prPrintItem :: TokenCat -> Either (Cat, Doc) TokenCat -> TokenCat
prPrintItem TokenCat
pre = \case
  Right TokenCat
t -> Doc -> TokenCat
render (TokenCat -> Doc
renderX TokenCat
t) TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
";"
  Left (Cat
cat, Doc
nt) -> [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ TokenCat
"pp"
    , TokenCat -> (TokenCat -> TokenCat) -> Maybe TokenCat -> TokenCat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Cat -> TokenCat
identCat (Cat -> TokenCat) -> Cat -> TokenCat
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat) TokenCat -> TokenCat
basicFunName (Maybe TokenCat -> TokenCat) -> Maybe TokenCat -> TokenCat
forall a b. (a -> b) -> a -> b
$ Cat -> Maybe TokenCat
maybeTokenCat Cat
cat
    , TokenCat
"(", TokenCat
pre, Doc -> TokenCat
render Doc
nt, TokenCat
", ", Integer -> TokenCat
forall a. Show a => a -> TokenCat
show (Cat -> Integer
precCat Cat
cat), TokenCat
");"
    ]

{- **** Abstract Syntax Tree Printer **** -}

-- | An entry point to the printer.

prShowFun :: Cat -> String
prShowFun :: Cat -> TokenCat
prShowFun Cat
ep | Cat -> Cat
normCat Cat
ep Cat -> Cat -> Bool
forall a. Eq a => a -> a -> Bool
== Cat
ep = [TokenCat] -> TokenCat
unlines
  [
   TokenCat
"char *show" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
ep' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
ep' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" p)",
   TokenCat
"{",
   TokenCat
"  _n_ = 0;",
   TokenCat
"  bufReset();",
   TokenCat
"  sh" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
ep' TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(p);",
   TokenCat
"  return buf_;",
   TokenCat
"}"
  ]
 where
  ep' :: TokenCat
ep' = Cat -> TokenCat
identCat Cat
ep
prShowFun Cat
_ = TokenCat
""

-- | This prints the functions for Abstract Syntax tree printing.

prShowData :: (Cat, [Rule]) -> String
prShowData :: (Cat, [Rul RFun]) -> TokenCat
prShowData (Cat
cat, [Rul RFun]
rules) = [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$
 if Cat -> Bool
isList Cat
cat
 then
 [
  TokenCat
"void sh" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"("TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
+++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
")",
  TokenCat
"{",
  TokenCat
"  bufAppendC('[');",
  TokenCat
"  while(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"!= 0)",
  TokenCat
"  {",
  TokenCat
"    if (" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"->" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"_)",
  TokenCat
"    {",
  TokenCat
visitMember,
  TokenCat
"      bufAppendS(\", \");",
  TokenCat
"      " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"=" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"->" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"_;",
  TokenCat
"    }",
  TokenCat
"    else",
  TokenCat
"    {",
  TokenCat
visitMember,
  TokenCat
"      " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" = 0;",
  TokenCat
"    }",
  TokenCat
"  }",
  TokenCat
"  bufAppendC(']');",
  TokenCat
"}",
  TokenCat
""
 ] -- Not a list:
 else
 [
   TokenCat
"void sh" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
cl TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
" p)",
   TokenCat
"{",
   TokenCat
"  switch(p->kind)",
   TokenCat
"  {",
   (Rul RFun -> TokenCat) -> [Rul RFun] -> TokenCat
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Rul RFun -> TokenCat
prShowRule [Rul RFun]
rules,
   TokenCat
"  default:",
   TokenCat
"    fprintf(stderr, \"Error: bad kind field when showing " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
catToStr Cat
cat TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"!\\n\");",
   TokenCat
"    exit(1);",
   TokenCat
"  }",
   TokenCat
"}\n"
 ]
 where
   cl :: TokenCat
cl = Cat -> TokenCat
identCat (Cat -> Cat
normCat Cat
cat)
   ecl :: TokenCat
ecl = Cat -> TokenCat
identCat (Cat -> Cat
normCatOfList Cat
cat)
   vname :: TokenCat
vname = (Char -> Char) -> TokenCat -> TokenCat
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower TokenCat
cl
   member :: TokenCat
member = (Char -> Char) -> TokenCat -> TokenCat
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower TokenCat
ecl
   visitMember :: TokenCat
visitMember = TokenCat
"      sh" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
ecl TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"(" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
vname TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"->" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
member TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"_);"

-- | Pretty Printer methods for a rule.

prShowRule :: Rule -> String
prShowRule :: Rul RFun -> TokenCat
prShowRule (Rule RFun
fun RCat
_ SentForm
cats InternalRule
_) | Bool -> Bool
not (RFun -> Bool
forall a. IsFun a => a -> Bool
isCoercion RFun
fun) = [TokenCat] -> TokenCat
unlines
  [
   TokenCat
"  case is_" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
f TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
":",
   TokenCat
"  " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
lparen,
   TokenCat
"    bufAppendS(\"" TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
f TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
"\");\n",
   TokenCat
"  " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
optspace,
   TokenCat
cats',
   TokenCat
"  " TokenCat -> TokenCat -> TokenCat
forall a. [a] -> [a] -> [a]
++ TokenCat
rparen,
   TokenCat
"    break;"
  ]
   where
    f :: TokenCat
f = RFun -> TokenCat
forall a. IsFun a => a -> TokenCat
funName RFun
fun
    (TokenCat
optspace, TokenCat
lparen, TokenCat
rparen) = if SentForm -> Bool
forall {a} {b}. [Either a b] -> Bool
allTerms SentForm
cats
      then (TokenCat
"",TokenCat
"",TokenCat
"")
      else (TokenCat
"  bufAppendC(' ');\n", TokenCat
"  bufAppendC('(');\n",TokenCat
"  bufAppendC(')');\n")
    cats' :: TokenCat
cats' = if SentForm -> Bool
forall {a} {b}. [Either a b] -> Bool
allTerms SentForm
cats
        then TokenCat
""
        else [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([TokenCat] -> [TokenCat]
forall {a}. (Eq a, IsString a) => [a] -> [a]
insertSpaces (((Cat, Doc) -> TokenCat) -> [(Cat, Doc)] -> [TokenCat]
forall a b. (a -> b) -> [a] -> [b]
map (TokenCat -> (Cat, Doc) -> TokenCat
prShowCat TokenCat
f) ([Either (Cat, Doc) TokenCat] -> [(Cat, Doc)]
forall a b. [Either a b] -> [a]
lefts ([Either (Cat, Doc) TokenCat] -> [(Cat, Doc)])
-> [Either (Cat, Doc) TokenCat] -> [(Cat, Doc)]
forall a b. (a -> b) -> a -> b
$ SentForm -> [Either (Cat, Doc) TokenCat]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars SentForm
cats)))
    insertSpaces :: [a] -> [a]
insertSpaces [] = []
    insertSpaces (a
x:[]) = [a
x]
    insertSpaces (a
x:[a]
xs) = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
""
      then [a] -> [a]
insertSpaces [a]
xs
      else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
"  bufAppendC(' ');\n" a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
insertSpaces [a]
xs
    allTerms :: [Either a b] -> Bool
allTerms [] = Bool
True
    allTerms (Left a
_:[Either a b]
_) = Bool
False
    allTerms (Either a b
_:[Either a b]
zs) = [Either a b] -> Bool
allTerms [Either a b]
zs
prShowRule Rul RFun
_ = TokenCat
""

prShowCat :: Fun -> (Cat, Doc) -> String
prShowCat :: TokenCat -> (Cat, Doc) -> TokenCat
prShowCat TokenCat
fnm (Cat
cat, Doc
nt) = [TokenCat] -> TokenCat
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ TokenCat
"    sh"
  , TokenCat -> (TokenCat -> TokenCat) -> Maybe TokenCat -> TokenCat
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Cat -> TokenCat
identCat (Cat -> TokenCat) -> Cat -> TokenCat
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat) TokenCat -> TokenCat
basicFunName (Maybe TokenCat -> TokenCat) -> Maybe TokenCat -> TokenCat
forall a b. (a -> b) -> a -> b
$ Cat -> Maybe TokenCat
maybeTokenCat Cat
cat
  , TokenCat
"(p->u."
  , (Char -> Char) -> TokenCat -> TokenCat
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower TokenCat
fnm
  , TokenCat
"_."
  , Doc -> TokenCat
render Doc
nt
  , TokenCat
");\n"
  ]

{- **** Helper Functions Section **** -}

-- | The visit-function name of a basic type.

basicFunName :: TokenCat -> String
basicFunName :: TokenCat -> TokenCat
basicFunName TokenCat
k
  | TokenCat
k TokenCat -> [TokenCat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TokenCat]
baseTokenCatNames = TokenCat
k
  | Bool
otherwise                  = TokenCat
"Ident"

-- | An extremely simple @renderC@ for terminals.

prRender :: String
prRender :: TokenCat
prRender = [TokenCat] -> TokenCat
unlines ([TokenCat] -> TokenCat) -> [TokenCat] -> TokenCat
forall a b. (a -> b) -> a -> b
$ [[TokenCat]] -> [TokenCat]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [
      TokenCat
"/* You may wish to change the renderC functions */",
      TokenCat
"void renderC(Char c)",
      TokenCat
"{",
      TokenCat
"  if (c == '{')",
      TokenCat
"  {",
      TokenCat
"     onEmptyLine();",
      TokenCat
"     bufAppendC(c);",
      TokenCat
"     _n_ = _n_ + INDENT_WIDTH;",
      TokenCat
"     bufAppendC('\\n');",
      TokenCat
"     indent();",
      TokenCat
"  }",
      TokenCat
"  else if (c == '(' || c == '[')",
      TokenCat
"     bufAppendC(c);",
      TokenCat
"  else if (c == ')' || c == ']')",
      TokenCat
"  {",
      TokenCat
"     removeTrailingWhitespace();",
      TokenCat
"     bufAppendC(c);",
      TokenCat
"     bufAppendC(' ');",
      TokenCat
"  }",
      TokenCat
"  else if (c == '}')",
      TokenCat
"  {",
      TokenCat
"     _n_ = _n_ - INDENT_WIDTH;",
      TokenCat
"     onEmptyLine();",
      TokenCat
"     bufAppendC(c);",
      TokenCat
"     bufAppendC('\\n\');",
      TokenCat
"     indent();",
      TokenCat
"  }",
      TokenCat
"  else if (c == ',')",
      TokenCat
"  {",
      TokenCat
"     removeTrailingWhitespace();",
      TokenCat
"     bufAppendC(c);",
      TokenCat
"     bufAppendC(' ');",
      TokenCat
"  }",
      TokenCat
"  else if (c == ';')",
      TokenCat
"  {",
      TokenCat
"     removeTrailingWhitespace();",
      TokenCat
"     bufAppendC(c);",
      TokenCat
"     bufAppendC('\\n');",
      TokenCat
"     indent();",
      TokenCat
"  }",
      TokenCat
"  else if (c == ' ') bufAppendC(c);",
      TokenCat
"  else if (c == 0) return;",
      TokenCat
"  else",
      TokenCat
"  {",
      TokenCat
"     bufAppendC(c);",
      TokenCat
"     bufAppendC(' ');",
      TokenCat
"  }",
      TokenCat
"}",
      TokenCat
"",
      TokenCat
"int allIsSpace(String s)",
      TokenCat
"{",
      TokenCat
"  char c;",
      TokenCat
"  while ((c = *s++))",
      TokenCat
"    if (! isspace(c)) return 0;",
      TokenCat
"  return 1;",
      TokenCat
"}",
      TokenCat
"",
      TokenCat
"void renderS(String s)",
      TokenCat
"{",
      TokenCat
"  if (*s) /* s[0] != '\\0', string s not empty */",
      TokenCat
"  {",
      TokenCat
"    if (allIsSpace(s)) {",
      TokenCat
"      backup();",
      TokenCat
"      bufAppendS(s);",
      TokenCat
"    } else {",
      TokenCat
"      bufAppendS(s);",
      TokenCat
"      bufAppendC(' ');",
      TokenCat
"    }",
      TokenCat
"  }",
      TokenCat
"}",
      TokenCat
"",
      TokenCat
"void indent(void)",
      TokenCat
"{",
      TokenCat
"  int n = _n_;",
      TokenCat
"  while (--n >= 0)",
      TokenCat
"    bufAppendC(' ');",
      TokenCat
"}",
      TokenCat
"",
      TokenCat
"void backup(void)",
      TokenCat
"{",
      TokenCat
"  if (cur_ && buf_[cur_ - 1] == ' ')",
      TokenCat
"    buf_[--cur_] = 0;",
      TokenCat
"}",
      TokenCat
""
    ]
  , [ TokenCat
"void removeTrailingSpaces()"
    , TokenCat
"{"
    , TokenCat
"  while (cur_ && buf_[cur_ - 1] == ' ') --cur_;"
    , TokenCat
"  buf_[cur_] = 0;"
    , TokenCat
"}"
    , TokenCat
""
    , TokenCat
"void removeTrailingWhitespace()"
    , TokenCat
"{"
    , TokenCat
"  while (cur_ && (buf_[cur_ - 1] == ' ' || buf_[cur_ - 1] == '\\n')) --cur_;"
    , TokenCat
"  buf_[cur_] = 0;"
    , TokenCat
"}"
    , TokenCat
""
    , TokenCat
"void onEmptyLine()"
    , TokenCat
"{"
    , TokenCat
"  removeTrailingSpaces();"
    , TokenCat
"  if (cur_ && buf_[cur_ - 1 ] != '\\n') bufAppendC('\\n');"
    , TokenCat
"  indent();"
    , TokenCat
"}"
    ]
  ]