{-# 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 -> (String, String)
cf2CSkel 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 (CF -> [(Cat, [Rule])]
ruleGroupsInternals CF
cf)


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

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

--Prints out visit functions for a category
prDataH :: (Cat, [Rule]) -> String
prDataH :: (Cat, [Rule]) -> String
prDataH (Cat
cat, [Rule]
_rules) =
    if Cat -> Bool
isList Cat
cat
      then [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"void visit", String
cl, String
"(", String
cl,  String
" p);\n"]
      else String
"void visit" 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);\n"
    where cl :: String
cl = Cat -> String
identCat (Cat -> String) -> Cat -> String
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])] -> String
mkCFile CF
cf [(Cat, [Rule])]
groups = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
header
  , ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Cat, [Rule]) -> String
prData [(Cat, [Rule])]
groups
  , (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
prUser [String]
user
  , String
footer
  ]
  where
    user :: [String]
user = ((String, Reg) -> String) -> [(String, Reg)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Reg) -> String
forall a b. (a, b) -> a
fst ([(String, Reg)] -> [String]) -> [(String, Reg)] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf
    header :: String
header = [String] -> String
unlines [
      String
"/*** BNFC-Generated Visitor Traversal Skeleton. ***/",
      String
"/* This traverses the abstract syntax tree.",
      String
"   To use, copy Skeleton.h and Skeleton.c to",
      String
"   new files. */",
      String
"",
      String
"#include <stdlib.h>",
      String
"#include <stdio.h>",
      String
"",
      String
"#include \"Skeleton.h\"",
      String
""
      ]
    prUser :: String -> String
prUser String
u = [String] -> String
unlines
     [
      String
"void visit" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
basicFunNameS String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p)",
      String
"{",
      String
"  /* Code for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Goes Here */",
      String
"}"
     ]
    footer :: String
footer = [String] -> String
unlines
     [
      String
"void visitIdent(Ident i)",
      String
"{",
      String
"  /* Code for Ident Goes Here */",
      String
"}",
      String
"void visitInteger(Integer i)",
      String
"{",
      String
"  /* Code for Integer Goes Here */",
      String
"}",
      String
"void visitDouble(Double d)",
      String
"{",
      String
"  /* Code for Double Goes Here */",
      String
"}",
      String
"void visitChar(Char c)",
      String
"{",
      String
"  /* Code for Char Goes Here */",
      String
"}",
      String
"void visitString(String s)",
      String
"{",
      String
"  /* Code for String Goes Here */",
      String
"}",
      String
""
     ]

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

-- | 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
    [ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"case is_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
    , Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat
        [ Doc
"/* Code for " Doc -> Doc -> Doc
<> String -> Doc
text String
fun Doc -> Doc -> Doc
<> Doc
" Goes Here */"
        , Doc
cats'
        , Doc
"break;\n"
        ])
    ]
  where
    fun :: String
fun = RFun -> String
forall a. IsFun a => a -> String
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 (String -> (Cat, Doc) -> Doc
prCat String
fun) ([Either (Cat, Doc) String] -> [(Cat, Doc)]
forall a b. [Either a b] -> [a]
lefts (SentForm -> [Either (Cat, Doc) String]
forall a. [Either Cat a] -> [Either (Cat, Doc) a]
numVars SentForm
cats))

-- Prints the actual instance-variable visiting.
prCat :: Fun -> (Cat, Doc) -> Doc
prCat :: String -> (Cat, Doc) -> Doc
prCat String
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 String -> Doc
text (Cat -> String
identCat (Cat -> Cat
normCat Cat
cat))
      in Doc
visitf Doc -> Doc -> Doc
<> Doc -> Doc
parens (Doc
"p->u." Doc -> Doc -> Doc
<> String -> Doc
text String
v Doc -> Doc -> Doc
<> Doc
"_." Doc -> Doc -> Doc
<> Doc
vname ) Doc -> Doc -> Doc
<> Doc
";"
    where v :: String
v = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
fnm

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

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

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