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

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

-- | Make the Header File.

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

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

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

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

prShowDataH :: (Cat, [Rule]) -> String
prShowDataH :: (Cat, [Rule]) -> String
prShowDataH (Cat
cat, [Rule]
_) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"void sh", String
cl, String
"(", String
cl, String
" p);\n"]
  where
   cl :: String
cl = Cat -> String
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, [Rule])] -> String
mkCFile CF
cf [(Cat, [Rule])]
groups = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
   [
    String
header,
    String
prRender,
    (Cat -> String) -> [Cat] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> String
prPrintFun [Cat]
eps,
    (Cat -> String) -> [Cat] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cat -> String
prShowFun [Cat]
eps,
    ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rule]) -> String
prPrintData [(Cat, [Rule])]
groups,
    String
printBasics,
    String
printTokens,
    ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rule]) -> String
prShowData [(Cat, [Rule])]
groups,
    String
showBasics,
    String
showTokens,
    String
footer
   ]
  where
    eps :: [Cat]
eps = [Cat] -> [Cat]
forall a. Eq a => [a] -> [a]
nub ([Cat] -> [Cat])
-> (NonEmpty Cat -> [Cat]) -> NonEmpty 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])
-> (NonEmpty Cat -> [Cat]) -> NonEmpty Cat -> [Cat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Cat -> [Cat]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Cat -> [Cat]) -> NonEmpty Cat -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
cf
    header :: String
header = [String] -> String
unlines
     [
      String
"/*** Pretty Printer and Abstract Syntax Viewer ***/",
      String
"",
      String
"#include <ctype.h>   /* isspace */",
      String
"#include <stddef.h>  /* size_t */",
      String
"#include <stdio.h>",
      String
"#include <string.h>",
      String
"#include <stdlib.h>",
      String
"#include \"Printer.h\"",
      String
"",
      String
"#define INDENT_WIDTH 2",
      String
"",
      String
"int _n_;",
      String
"char *buf_;",
      String
"size_t cur_;",
      String
"size_t buf_size;",
      String
""
     ]
    printBasics :: String
printBasics = [String] -> String
unlines
     [
      String
"void ppInteger(Integer n, int i)",
      String
"{",
      -- 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.
      String
"  char tmp[20];",
      String
"  sprintf(tmp, \"%d\", n);",
      String
"  renderS(tmp);",
      String
"}",
      String
"void ppDouble(Double d, int i)",
      String
"{",
      -- 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
      String
"  char tmp[24];",
      String
"  sprintf(tmp, \"%.15g\", d);",
      String
"  renderS(tmp);",
      String
"}",
      String
"void ppChar(Char c, int i)",
      String
"{",
      String
"  char tmp[4];",
      String
"  sprintf(tmp, \"'%c'\", c);",
      String
"  renderS(tmp);",
      String
"}",
      String
"void ppString(String s, int i)",
      String
"{",
      String
"  bufAppendC('\\\"');",
      String
"  bufAppendS(s);",
      String
"  bufAppendC('\\\"');",
      String
"  bufAppendC(' ');",
      String
"}",
      String
"void ppIdent(String s, int i)",
      String
"{",
      String
"  renderS(s);",
      String
"}",
      String
""
     ]
    printTokens :: String
printTokens = [String] -> String
unlines
     [[String] -> String
unlines [
      String
"void pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(String s, int i)",
      String
"{",
      String
"  renderS(s);",
      String
"}",
      String
""
      ] | String
t <- CF -> [String]
forall f. CFG f -> [String]
tokenNames CF
cf
     ]
    showBasics :: String
showBasics = [String] -> String
unlines
     [
      String
"void shInteger(Integer i)",
      String
"{",
      String
"  char tmp[20];",
      String
"  sprintf(tmp, \"%d\", i);",
      String
"  bufAppendS(tmp);",
      String
"}",
      String
"void shDouble(Double d)",
      String
"{",
      String
"  char tmp[24];",
      String
"  sprintf(tmp, \"%.15g\", d);",
      String
"  bufAppendS(tmp);",
      String
"}",
      String
"void shChar(Char c)",
      String
"{",
      String
"  bufAppendC('\\'');",
      String
"  bufAppendC(c);",
      String
"  bufAppendC('\\'');",
      String
"}",
      String
"void shString(String s)",
      String
"{",
      String
"  bufAppendC('\\\"');",
      String
"  bufAppendS(s);",
      String
"  bufAppendC('\\\"');",
      String
"}",
      String
"void shIdent(String s)",
      String
"{",
      String
"  bufAppendC('\\\"');",
      String
"  bufAppendS(s);",
      String
"  bufAppendC('\\\"');",
      String
"}",
      String
""
     ]
    showTokens :: String
showTokens = [String] -> String
unlines
     [[String] -> String
unlines [
      String
"void sh" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(String s)",
      String
"{",
      String
"  bufAppendC('\\\"');",
      String
"  bufAppendS(s);",
      String
"  bufAppendC('\\\"');",
      String
"}",
      String
""
      ] | String
t <- CF -> [String]
forall f. CFG f -> [String]
tokenNames CF
cf
     ]
    footer :: String
footer = [String] -> String
unlines
     [
      String
"void bufAppendS(const char *s)",
      String
"{",
      String
"  size_t len = strlen(s);",
      String
"  size_t n;",
      String
"  while (cur_ + len >= buf_size)",
      String
"  {",
      String
"    buf_size *= 2; /* Double the buffer size */",
      String
"    resizeBuffer();",
      String
"  }",
      String
"  for(n = 0; n < len; n++)",
      String
"  {",
      String
"    buf_[cur_ + n] = s[n];",
      String
"  }",
      String
"  cur_ += len;",
      String
"  buf_[cur_] = 0;",
      String
"}",
      String
"void bufAppendC(const char c)",
      String
"{",
      String
"  if (cur_ + 1 >= buf_size)",
      String
"  {",
      String
"    buf_size *= 2; /* Double the buffer size */",
      String
"    resizeBuffer();",
      String
"  }",
      String
"  buf_[cur_] = c;",
      String
"  cur_++;",
      String
"  buf_[cur_] = 0;",
      String
"}",
      String
"void bufReset(void)",
      String
"{",
      String
"  cur_ = 0;",
      String
"  buf_size = BUFFER_INITIAL;",
      String
"  resizeBuffer();",
      String
"  memset(buf_, 0, buf_size);",
      String
"}",
      String
"void resizeBuffer(void)",
      String
"{",
      String
"  char *temp = (char *) malloc(buf_size);",
      String
"  if (!temp)",
      String
"  {",
      String
"    fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",
      String
"    exit(1);",
      String
"  }",
      String
"  if (buf_)",
      String
"  {",
      String
"    strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */",
      String
"    free(buf_);",
      String
"  }",
      String
"  buf_ = temp;",
      String
"}",
      String
"char *buf_;",
      String
"size_t cur_, buf_size;",
      String
""
     ]


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

-- | An entry point to the printer.

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

-- Generates methods for the Pretty Printer

prPrintData :: (Cat, [Rule]) -> String
prPrintData :: (Cat, [Rule]) -> String
prPrintData (Cat
cat, [Rule]
rules)
  | Cat -> Bool
isList Cat
cat = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"void pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"("String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
+++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", int i)"
      , String
"{"
      , String
"  if (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
+++ String
"== 0)"
      , String
"  { /* nil */"
      ]
    , [Doc] -> ([Doc] -> [String]) -> [String]
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (((Integer, Rule) -> Bool) -> [Doc]
swRules (Integer, Rule) -> Bool
forall a. IsFun a => a -> Bool
isNilFun) (([Doc] -> [String]) -> [String])
-> ([Doc] -> [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ \ [Doc]
docs ->
      [ Doc -> String
render (Doc -> String) -> Doc -> String
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 ]
    , [ String
"  }" ]
    , [Doc] -> ([Doc] -> [String]) -> [String]
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (((Integer, Rule) -> Bool) -> [Doc]
swRules (Integer, Rule) -> Bool
forall a. IsFun a => a -> Bool
isOneFun) (([Doc] -> [String]) -> [String])
-> ([Doc] -> [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ \ [Doc]
docs ->
      [ String
"  else if (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_ == 0)"
      , String
"  { /* last */"
      , Doc -> String
render (Doc -> String) -> Doc -> String
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
      , String
"  }"
      ]
    , [Doc] -> ([Doc] -> [String]) -> [String]
forall m a. Monoid m => [a] -> ([a] -> m) -> m
unlessNull (((Integer, Rule) -> Bool) -> [Doc]
swRules (Integer, Rule) -> Bool
forall a. IsFun a => a -> Bool
isConsFun) (([Doc] -> [String]) -> [String])
-> ([Doc] -> [String]) -> [String]
forall a b. (a -> b) -> a -> b
$ \ [Doc]
docs ->
      [ String
"  else"
      , String
"  { /* cons */"
      , Doc -> String
render (Doc -> String) -> Doc -> String
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
      , String
"  }"
      ]
    , [ String
"}"
      , String
""
      ]
    ]
  | Bool
otherwise = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"void pp" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p, int _i_)"
      , String
"{"
      , String
"  switch(p->kind)"
      , String
"  {"
      ]
    , (Rule -> [String]) -> [Rule] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Rule -> [String]
prPrintRule [Rule]
rules
    , [ String
"  default:"
      , String
"    fprintf(stderr, \"Error: bad kind field when printing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
catToStr Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!\\n\");"
      , String
"    exit(1);"
      , String
"  }"
      , String
"}"
      , String
""
      ]
    ]
 where
   cl :: String
cl          = Cat -> String
identCat (Cat -> Cat
normCat Cat
cat)
   vname :: String
vname       = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cl
   pre :: String
pre         = String
vname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->"
   prules :: [(Integer, Rule)]
prules      = [Rule] -> [(Integer, Rule)]
sortRulesByPrecedence [Rule]
rules
   swRules :: ((Integer, Rule) -> Bool) -> [Doc]
swRules (Integer, Rule) -> Bool
f   = Doc -> [(Integer, Doc)] -> [Doc]
switchByPrecedence Doc
"i" ([(Integer, Doc)] -> [Doc]) -> [(Integer, Doc)] -> [Doc]
forall a b. (a -> b) -> a -> b
$
                   ((Integer, Rule) -> (Integer, Doc))
-> [(Integer, Rule)] -> [(Integer, Doc)]
forall a b. (a -> b) -> [a] -> [b]
map ((Rule -> Doc) -> (Integer, Rule) -> (Integer, Doc)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Rule -> Doc) -> (Integer, Rule) -> (Integer, Doc))
-> (Rule -> Doc) -> (Integer, Rule) -> (Integer, Doc)
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> (Rule -> [Doc]) -> Rule -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> (Rule -> [String]) -> Rule -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Rule -> [String]
forall a. IsFun a => String -> Rul a -> [String]
prPrintRule_ String
pre) ([(Integer, Rule)] -> [(Integer, Doc)])
-> [(Integer, Rule)] -> [(Integer, Doc)]
forall a b. (a -> b) -> a -> b
$
                     ((Integer, Rule) -> Integer)
-> [(Integer, Rule)] -> [(Integer, Rule)]
forall b a. Eq b => (a -> b) -> [a] -> [a]
uniqOn (Integer, Rule) -> Integer
forall a b. (a, b) -> a
fst ([(Integer, Rule)] -> [(Integer, Rule)])
-> [(Integer, Rule)] -> [(Integer, Rule)]
forall a b. (a -> b) -> a -> b
$ ((Integer, Rule) -> Bool) -> [(Integer, Rule)] -> [(Integer, Rule)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Integer, Rule) -> Bool
f [(Integer, Rule)]
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 :: String -> Doc
renderX String
sep' = Doc
"render" Doc -> Doc -> Doc
<> Char -> Doc
char Char
sc Doc -> Doc -> Doc
<> Doc -> Doc
parens (String -> Doc
text String
sep)
  where (Char
sc, String
sep) = String -> (Char, String)
renderCharOrString String
sep'


-- | Pretty Printer methods for a rule.

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

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

prPrintRule_ :: IsFun a => String -> Rul a -> [String]
prPrintRule_ :: String -> Rul a -> [String]
prPrintRule_ String
pre (Rule a
_ RCat
_ SentForm
items InternalRule
_) = (Either (Cat, Doc) String -> String)
-> [Either (Cat, Doc) String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Either (Cat, Doc) String -> String
prPrintItem String
pre) ([Either (Cat, Doc) String] -> [String])
-> [Either (Cat, Doc) String] -> [String]
forall a b. (a -> b) -> a -> b
$ SentForm -> [Either (Cat, Doc) String]
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 :: String -> Either (Cat, Doc) String -> String
prPrintItem String
pre = \case
  Right String
t -> Doc -> String
render (String -> Doc
renderX String
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
  Left (Cat
cat, Doc
nt) -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"pp"
    , String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Cat -> String
identCat (Cat -> String) -> Cat -> String
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat) String -> String
basicFunName (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Cat -> Maybe String
maybeTokenCat Cat
cat
    , String
"(", String
pre, Doc -> String
render Doc
nt, String
", ", Integer -> String
forall a. Show a => a -> String
show (Cat -> Integer
precCat Cat
cat), String
");"
    ]

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

-- | An entry point to the printer.

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

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

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

-- | Pretty Printer methods for a rule.

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

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

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

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

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

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

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