content: {-# 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                         ( (+++), capitalize )
  import BNFC.Backend.Common.NamedVariables
  import BNFC.Backend.C.Common              ( memName )
  import Data.Char                          ( toLower )
  import Data.Either                        ( lefts )
  
  import Text.PrettyPrint
  
  --Produces (.H file, .C file)
  cf2CSkel :: CF -> (String, String)
  cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups)
   where
      groups = fixCoercions (ruleGroupsInternals cf)
  
  
  {- **** Header (.H) File Functions **** -}
  
  --Generates the Header File
  mkHFile :: CF -> [(Cat,[Rule])] -> String
  mkHFile cf groups = unlines
   [
    header,
    concatMap prDataH groups,
    concatMap prUserH user,
    footer
   ]
   where
    user = map fst $ tokenPragmas cf
    header = unlines
     [
      "#ifndef SKELETON_HEADER",
      "#define SKELETON_HEADER",
      "/* You might want to change the above name. */",
      "",
      "#include \"Absyn.h\"",
      ""
     ]
    prUserH u = "void visit" ++ basicFunNameS u ++ "(" ++ u ++ " p);"
    footer = unlines
     [
      "void visitIdent(Ident i);",
      "void visitInteger(Integer i);",
      "void visitDouble(Double d);",
      "void visitChar(Char c);",
      "void visitString(String s);",
      "",
      "#endif"
     ]
  
  --Prints out visit functions for a category
  prDataH :: (Cat, [Rule]) -> String
  prDataH (cat, _rules) =
      if isList cat
        then concat ["void visit", cl, "(", cl,  " p);\n"]
        else "void visit" ++ cl ++ "(" ++ cl ++ " p);\n"
      where cl = identCat $ normCat cat
  
  {- **** Implementation (.C) File Functions **** -}
  
  -- | Makes the skeleton's .c File
  mkCFile :: CF -> [(Cat,[Rule])] -> String
  mkCFile cf groups = concat
    [ header
    , concatMap prData groups
    , concatMap prUser user
    , footer
    ]
    where
      user = map fst $ tokenPragmas cf
      header = unlines [
        "/*** Visitor Traversal Skeleton. ***/",
        "/* This traverses the abstract syntax tree.",
        "   To use, copy Skeleton.h and Skeleton.c to",
        "   new files. */",
        "",
        "#include <stdlib.h>",
        "#include <stdio.h>",
        "",
        "#include \"Skeleton.h\"",
        ""
        ]
      prUser u = unlines
       [
        "void visit" ++ basicFunNameS u ++ "(" ++ u ++ " p)",
        "{",
        "  /* Code for " ++ u ++ " Goes Here */",
        "}"
       ]
      footer = unlines
       [
        "void visitIdent(Ident i)",
        "{",
        "  /* Code for Ident Goes Here */",
        "}",
        "void visitInteger(Integer i)",
        "{",
        "  /* Code for Integer Goes Here */",
        "}",
        "void visitDouble(Double d)",
        "{",
        "  /* Code for Double Goes Here */",
        "}",
        "void visitChar(Char c)",
        "{",
        "  /* Code for Char Goes Here */",
        "}",
        "void visitString(String s)",
        "{",
        "  /* Code for String Goes Here */",
        "}",
        ""
       ]
  
  --Visit functions for a category.
  prData :: (Cat, [Rule]) -> String
  prData (cat, rules)
    | isList cat = unlines
                 [
                  "void visit" ++ cl ++ "("++ cl +++ vname ++ ")",
                  "{",
                  "  while(" ++ vname +++ " != 0)",
                  "  {",
                  "    /* Code For " ++ cl ++ " Goes Here */",
                  "    visit" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);",
                  "    " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",
                  "  }",
                  "}",
                  ""
                 ]
        -- Not a list:
    | otherwise = unlines
                 [
                  "void visit" ++ cl ++ "(" ++ cl ++ " p)",
                  "{",
                  "  switch(p->kind)",
                  "  {",
                  concatMap (render . prPrintRule) rules,
                  "  default:",
                  "    fprintf(stderr, \"Error: bad kind field when printing " ++ cl ++ "!\\n\");",
                  "    exit(1);",
                  "  }",
                  "}\n"
                 ]
      where cl = identCat $ normCat cat
            ecl = identCat $ normCatOfList cat
            vname = map toLower cl
            member = map toLower 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 f _c cats _)
    | isCoercion f    = empty
    | isDefinedRule f = empty
    | otherwise       = nest 2 $ vcat
      [ text $ "case is_" ++ fun ++ ":"
      , nest 2 (vcat
          [ "/* Code for " <> text fun <> " Goes Here */"
          , cats'
          , "break;\n"
          ])
      ]
    where
      fun = funName f
      cats' = vcat $ map (prCat fun) (lefts (numVars cats))
  
  -- Prints the actual instance-variable visiting.
  prCat :: Fun -> (Cat, Doc) -> Doc
  prCat fnm (cat, vname) =
        let visitf = "visit" <> if isTokenCat cat
                         then basicFunName cat
                         else text (identCat (normCat cat))
        in visitf <> parens ("p->u." <> text (memName fnm) <> "." <> vname ) <> ";"
  
  -- | The visit-function name of a basic type
  
  basicFunName :: Cat -> Doc
  basicFunName = text . basicFunNameS . catToStr
  
  basicFunNameS :: String -> String
  basicFunNameS = capitalize
  