{-# LANGUAGE OverloadedStrings #-}

{-
    BNF Converter: C Skeleton generator
    Copyright (C) 2004  Author:  Michael Pellauer

    Description   : This module generates the C Skeleton functions.

                    The generated files follow Appel's case method.

    Author        : Michael Pellauer
    Created       : 9 August, 2003
-}

module BNFC.Backend.C.CFtoCSkel (cf2CSkel) where

import Prelude hiding ((<>))

import BNFC.CF
import BNFC.Utils                       ( (+++) )
import BNFC.Backend.Common.NamedVariables
import Data.Char                ( toLower, toUpper )
import Data.Either (lefts)

import Text.PrettyPrint

--Produces (.H file, .C file)
cf2CSkel :: CF -> (String, String)
cf2CSkel :: CF -> ([Char], [Char])
cf2CSkel CF
cf = (CF -> [(Cat, [Rule])] -> [Char]
mkHFile CF
cf [(Cat, [Rule])]
groups, CF -> [(Cat, [Rule])] -> [Char]
mkCFile CF
cf [(Cat, [Rule])]
groups)
 where
    groups :: [(Cat, [Rule])]
groups = [(Cat, [Rule])] -> [(Cat, [Rule])]
fixCoercions (CF -> [(Cat, [Rule])]
ruleGroupsInternals CF
cf)


{- **** Header (.H) File Functions **** -}

--Generates the Header File
mkHFile :: CF -> [(Cat,[Rule])] -> String
mkHFile :: CF -> [(Cat, [Rule])] -> [Char]
mkHFile CF
cf [(Cat, [Rule])]
groups = [[Char]] -> [Char]
unlines
 [
  [Char]
header,
  ((Cat, [Rule]) -> [Char]) -> [(Cat, [Rule])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rule]) -> [Char]
prDataH [(Cat, [Rule])]
groups,
  ([Char] -> [Char]) -> [[Char]] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [Char]
prUserH [[Char]]
user,
  [Char]
footer
 ]
 where
  user :: [[Char]]
user = (([Char], Reg) -> [Char]) -> [([Char], Reg)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Reg) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], Reg)] -> [[Char]]) -> [([Char], Reg)] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [([Char], Reg)]
forall f. CFG f -> [([Char], Reg)]
tokenPragmas CF
cf
  header :: [Char]
header = [[Char]] -> [Char]
unlines
   [
    [Char]
"#ifndef SKELETON_HEADER",
    [Char]
"#define SKELETON_HEADER",
    [Char]
"/* You might want to change the above name. */",
    [Char]
"",
    [Char]
"#include \"Absyn.h\"",
    [Char]
""
   ]
  prUserH :: [Char] -> [Char]
prUserH [Char]
u = [Char]
"void visit" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
basicFunNameS [Char]
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p);"
  footer :: [Char]
footer = [[Char]] -> [Char]
unlines
   [
    [Char]
"void visitIdent(Ident i);",
    [Char]
"void visitInteger(Integer i);",
    [Char]
"void visitDouble(Double d);",
    [Char]
"void visitChar(Char c);",
    [Char]
"void visitString(String s);",
    [Char]
"",
    [Char]
"#endif"
   ]

--Prints out visit functions for a category
prDataH :: (Cat, [Rule]) -> String
prDataH :: (Cat, [Rule]) -> [Char]
prDataH (Cat
cat, [Rule]
_rules) =
    if Cat -> Bool
isList Cat
cat
      then [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"void visit", [Char]
cl, [Char]
"(", [Char]
cl,  [Char]
" p);\n"]
      else [Char]
"void visit" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p);\n"
    where cl :: [Char]
cl = Cat -> [Char]
identCat (Cat -> [Char]) -> Cat -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat

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

-- | Makes the skeleton's .c File
mkCFile :: CF -> [(Cat,[Rule])] -> String
mkCFile :: CF -> [(Cat, [Rule])] -> [Char]
mkCFile CF
cf [(Cat, [Rule])]
groups = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [Char]
header
  , ((Cat, [Rule]) -> [Char]) -> [(Cat, [Rule])] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rule]) -> [Char]
prData [(Cat, [Rule])]
groups
  , ([Char] -> [Char]) -> [[Char]] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [Char]
prUser [[Char]]
user
  , [Char]
footer
  ]
  where
    user :: [[Char]]
user = (([Char], Reg) -> [Char]) -> [([Char], Reg)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Reg) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], Reg)] -> [[Char]]) -> [([Char], Reg)] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [([Char], Reg)]
forall f. CFG f -> [([Char], Reg)]
tokenPragmas CF
cf
    header :: [Char]
header = [[Char]] -> [Char]
unlines [
      [Char]
"/*** BNFC-Generated Visitor Traversal Skeleton. ***/",
      [Char]
"/* This traverses the abstract syntax tree.",
      [Char]
"   To use, copy Skeleton.h and Skeleton.c to",
      [Char]
"   new files. */",
      [Char]
"",
      [Char]
"#include <stdlib.h>",
      [Char]
"#include <stdio.h>",
      [Char]
"",
      [Char]
"#include \"Skeleton.h\"",
      [Char]
""
      ]
    prUser :: [Char] -> [Char]
prUser [Char]
u = [[Char]] -> [Char]
unlines
     [
      [Char]
"void visit" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
basicFunNameS [Char]
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p)",
      [Char]
"{",
      [Char]
"  /* Code for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
u [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" Goes Here */",
      [Char]
"}"
     ]
    footer :: [Char]
footer = [[Char]] -> [Char]
unlines
     [
      [Char]
"void visitIdent(Ident i)",
      [Char]
"{",
      [Char]
"  /* Code for Ident Goes Here */",
      [Char]
"}",
      [Char]
"void visitInteger(Integer i)",
      [Char]
"{",
      [Char]
"  /* Code for Integer Goes Here */",
      [Char]
"}",
      [Char]
"void visitDouble(Double d)",
      [Char]
"{",
      [Char]
"  /* Code for Double Goes Here */",
      [Char]
"}",
      [Char]
"void visitChar(Char c)",
      [Char]
"{",
      [Char]
"  /* Code for Char Goes Here */",
      [Char]
"}",
      [Char]
"void visitString(String s)",
      [Char]
"{",
      [Char]
"  /* Code for String Goes Here */",
      [Char]
"}",
      [Char]
""
     ]

--Visit functions for a category.
prData :: (Cat, [Rule]) -> String
prData :: (Cat, [Rule]) -> [Char]
prData (Cat
cat, [Rule]
rules)
  | Cat -> Bool
isList Cat
cat = [[Char]] -> [Char]
unlines
               [
                [Char]
"void visit" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"("[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
+++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")",
                [Char]
"{",
                [Char]
"  while(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
+++ [Char]
" != 0)",
                [Char]
"  {",
                [Char]
"    /* Code For " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" Goes Here */",
                [Char]
"    visit" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ecl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
member [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_);",
                [Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
+++ [Char]
"=" [Char] -> [Char] -> [Char]
+++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"->" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
vname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_;",
                [Char]
"  }",
                [Char]
"}",
                [Char]
""
               ]
      -- Not a list:
  | Bool
otherwise = [[Char]] -> [Char]
unlines
               [
                [Char]
"void visit" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" p)",
                [Char]
"{",
                [Char]
"  switch(p->kind)",
                [Char]
"  {",
                (Rule -> [Char]) -> [Rule] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Doc -> [Char]
render (Doc -> [Char]) -> (Rule -> Doc) -> Rule -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> Doc
prPrintRule) [Rule]
rules,
                [Char]
"  default:",
                [Char]
"    fprintf(stderr, \"Error: bad kind field when printing " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!\\n\");",
                [Char]
"    exit(1);",
                [Char]
"  }",
                [Char]
"}\n"
               ]
    where cl :: [Char]
cl = Cat -> [Char]
identCat (Cat -> [Char]) -> Cat -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
cat
          ecl :: [Char]
ecl = Cat -> [Char]
identCat (Cat -> [Char]) -> Cat -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCatOfList Cat
cat
          vname :: [Char]
vname = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
cl
          member :: [Char]
member = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
ecl

-- | Visits all the instance variables of a category.
-- >>> let ab = Cat "ab"
-- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab] Parsable)
--   case is_abc:
--     /* Code for abc Goes Here */
--     visitab(p->u.abc_.ab_1);
--     visitab(p->u.abc_.ab_2);
--     break;
-- <BLANKLINE>
-- >>> let ab = TokenCat "ab"
-- >>> prPrintRule (Rule "abc" undefined [Left ab] Parsable)
--   case is_abc:
--     /* Code for abc Goes Here */
--     visitAb(p->u.abc_.ab_);
--     break;
-- <BLANKLINE>
-- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab] Parsable)
--   case is_abc:
--     /* Code for abc Goes Here */
--     visitAb(p->u.abc_.ab_1);
--     visitAb(p->u.abc_.ab_2);
--     break;
-- <BLANKLINE>
prPrintRule :: Rule -> Doc
prPrintRule :: Rule -> Doc
prPrintRule (Rule RFun
f RCat
_c SentForm
cats InternalRule
_)
  | RFun -> Bool
forall a. IsFun a => a -> Bool
isCoercion RFun
f   = Doc
""
  | Bool
otherwise      = Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
    [ [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"case is_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fun [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":"
    , Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat
        [ Doc
"/* Code for " Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
fun Doc -> Doc -> Doc
<> Doc
" Goes Here */"
        , Doc
cats'
        , Doc
"break;\n"
        ])
    ]
  where
    fun :: [Char]
fun = RFun -> [Char]
forall a. IsFun a => a -> [Char]
funName RFun
f
    cats' :: Doc
cats' = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((Cat, Doc) -> Doc) -> [(Cat, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> (Cat, Doc) -> Doc
prCat [Char]
fun) ([Either (Cat, Doc) [Char]] -> [(Cat, Doc)]
forall a b. [Either a b] -> [a]
lefts (SentForm -> [Either (Cat, Doc) [Char]]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars SentForm
cats))

-- Prints the actual instance-variable visiting.
prCat :: Fun -> (Cat, Doc) -> Doc
prCat :: [Char] -> (Cat, Doc) -> Doc
prCat [Char]
fnm (Cat
cat, Doc
vname) =
      let visitf :: Doc
visitf = Doc
"visit" Doc -> Doc -> Doc
<> if Cat -> Bool
isTokenCat Cat
cat
                       then Cat -> Doc
basicFunName Cat
cat
                       else [Char] -> Doc
text (Cat -> [Char]
identCat (Cat -> Cat
normCat Cat
cat))
      in Doc
visitf Doc -> Doc -> Doc
<> Doc -> Doc
parens (Doc
"p->u." Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
v Doc -> Doc -> Doc
<> Doc
"_." Doc -> Doc -> Doc
<> Doc
vname ) Doc -> Doc -> Doc
<> Doc
";"
    where v :: [Char]
v = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
fnm

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

basicFunName :: Cat -> Doc
basicFunName :: Cat -> Doc
basicFunName = [Char] -> Doc
text ([Char] -> Doc) -> (Cat -> [Char]) -> Cat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
basicFunNameS ([Char] -> [Char]) -> (Cat -> [Char]) -> Cat -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> [Char]
catToStr

basicFunNameS :: String -> String
basicFunNameS :: [Char] -> [Char]
basicFunNameS (Char
c:[Char]
cs) = Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
basicFunNameS []     = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible: empty string in CFtoCSkel.basicFunNameS"