Fix #479: C backend: preserve case in union member names

.github/workflows/haskell-ci.yml

@@ -8,45 +8,48 @@
 #
 # For more information, see https://github.com/andreasabel/haskell-ci
 #
-# version: 0.17.20231012
+# version: 0.19.20240422
 #
-# REGENDATA ("0.17.20231012",["github","cabal.project"])
+# REGENDATA ("0.19.20240422",["github","cabal.project"])
 #
 name: Haskell-CI
 on:
   push:
     branches:
       - master
-      - ci*
   pull_request:
     branches:
       - master
-      - ci*
 jobs:
   linux:
     name: Haskell-CI - Linux - ${{ matrix.compiler }}
     runs-on: ubuntu-20.04
     timeout-minutes:
       60
     container:
-      image: buildpack-deps:focal
+      image: buildpack-deps:jammy
     continue-on-error: ${{ matrix.allow-failure }}
     strategy:
       matrix:
         include:
-          - compiler: ghc-9.8.1
+          - compiler: ghc-9.10.0.20240413
             compilerKind: ghc
-            compilerVersion: 9.8.1
+            compilerVersion: 9.10.0.20240413
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.6.3
+          - compiler: ghc-9.8.2
             compilerKind: ghc
-            compilerVersion: 9.6.3
+            compilerVersion: 9.8.2
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.4.7
+          - compiler: ghc-9.6.5
             compilerKind: ghc
-            compilerVersion: 9.4.7
+            compilerVersion: 9.6.5
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.4.8
+            compilerKind: ghc
+            compilerVersion: 9.4.8
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.2.8
@@ -89,34 +92,18 @@ jobs:
             compilerVersion: 8.0.2
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-7.10.3
-            compilerKind: ghc
-            compilerVersion: 7.10.3
-            setup-method: hvr-ppa
-            allow-failure: false
       fail-fast: false
     steps:
       - name: apt
         run: |
           apt-get update
           apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
-            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup"
-            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml;
-            "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
-          else
-            apt-add-repository -y 'ppa:hvr/ghc'
-            apt-get update
-            apt-get install -y "$HCNAME"
-            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup"
-            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml;
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
-          fi
+          mkdir -p "$HOME/.ghcup/bin"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
+          chmod a+x "$HOME/.ghcup/bin/ghcup"
+          "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml;
+          "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
+          "$HOME/.ghcup/bin/ghcup" install cabal 3.10.3.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
         env:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
@@ -128,27 +115,18 @@ jobs:
           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
           HCDIR=/opt/$HCKIND/$HCVER
-          if [ "${{ matrix.setup-method }}" = ghcup ]; then
-            HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
-            HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
-            HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
-            echo "HC=$HC" >> "$GITHUB_ENV"
-            echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
-            echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          else
-            HC=$HCDIR/bin/$HCKIND
-            echo "HC=$HC" >> "$GITHUB_ENV"
-            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
-            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
-          fi
-
+          HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
+          HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
+          HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
+          echo "HC=$HC" >> "$GITHUB_ENV"
+          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
+          echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.3.0 -vnormal+nowrap" >> "$GITHUB_ENV"
           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
           echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
-          echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
+          if [ $((HCNUMVER >= 91000)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
           echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
           echo "GHCJSARITH=0" >> "$GITHUB_ENV"
         env:
@@ -177,8 +155,18 @@ jobs:
           repository hackage.haskell.org
             url: http://hackage.haskell.org/
           EOF
+          if $HEADHACKAGE; then
           cat >> $CABAL_CONFIG <<EOF
+          repository head.hackage.ghc.haskell.org
+             url: https://ghc.gitlab.haskell.org/head.hackage/
+             secure: True
+             root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
+                        26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
+                        f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
+             key-threshold: 3
+          active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org:override
           EOF
+          fi
           cat $CABAL_CONFIG
       - name: versions
         run: |
@@ -232,6 +220,9 @@ jobs:
           if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "    ghc-options: -Werror=missing-methods" >> cabal.project ; fi
           cat >> cabal.project <<EOF
           EOF
+          if $HEADHACKAGE; then
+          echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project
+          fi
           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(BNFC|bnfc-system-tests)$/; }' >> cabal.project.local
           cat cabal.project
           cat cabal.project.local

cabal.haskell-ci

@@ -1,7 +1,7 @@
 -- -- The name of GitHub Action
 -- github-action-name:
 
-branches: master ci*
+branches: master
 
 -- 2021-01-22 if cabal-version is greater than shipped Cabal, allow newer Cabal version
 -- https://github.com/haskell-CI/haskell-ci/issues/468#issuecomment-761865807

source/BNFC.cabal

@@ -32,8 +32,9 @@ Description:
 
 -- Support range when build with cabal
 tested-with:
-  GHC == 9.8.1
-  GHC == 9.6.3
+  GHC == 9.10.0
+  GHC == 9.8.2
+  GHC == 9.6.5
   GHC == 9.4.8
   GHC == 9.2.8
   GHC == 9.0.2
@@ -43,7 +44,7 @@ tested-with:
   GHC == 8.4.4
   GHC == 8.2.2
   GHC == 8.0.2
-  GHC == 7.10.3
+  -- GHC == 7.10.3
 
 extra-doc-files:
   README.md

source/CHANGELOG.md

@@ -1,5 +1,7 @@
 # Unreleased
 
+* C: preserve case in constructors (union): e.g. label `EInt` now is union member `eInt_` rather than `eint_`
+  [[#479](https://github.com/BNFC/bnfc/issues/479)]
 
 # 2.9.5
 

source/Makefile

@@ -8,7 +8,7 @@ CABAL_BUILDDIR_SUFFIX=
 CABAL_BUILD_OPTS     = --enable-tests
 # --builddir=dist-ghc-$(GHC_VERSION)$(CABAL_BUILDDIR_SUFFIX)
 CABAL_CONFIGURE_OPTS = --enable-tests
-CABAL_INSTALL_OPTS   = $(CABAL_CONFIGURE_OPTS) $(CABAL_BUILD_OPTS) --overwrite-policy=always
+CABAL_INSTALL_OPTS   = --overwrite-policy=always
 CABAL_TEST_OPTS      = $(CABAL_BUILD_OPTS)
 
 CABAL                = cabal $(CABAL_OPTS)
@@ -38,7 +38,7 @@ cabal-test:
 doctest: build doctest-install doctest-quick
 
 doctest-install:
-	cabal install doctest --program-suffix=-${GHC_VERSION}
+	cabal install doctest --ignore-project --program-suffix=-${GHC_VERSION}
 
 doctest-quick:
 	cabal repl -w doctest-${GHC_VERSION} --repl-options=-Wno-type-defaults

source/src/BNFC/Backend/C/CFtoCAbs.hs

@@ -35,7 +35,7 @@ import BNFC.PrettyPrint
 import BNFC.Options  ( RecordPositions(..) )
 import BNFC.Utils    ( (+++), unless )
 import BNFC.Backend.Common.NamedVariables
-import BNFC.Backend.C.Common ( posixC )
+import BNFC.Backend.C.Common ( posixC, memName )
 
 
 -- | The result is two files (.H file, .C file)
@@ -304,12 +304,12 @@ mkCFile datas _cf = concat
 --   switch(p->kind)
 --   {
 --   case is_EInt:
---     return make_EInt (p->u.eint_.integer_);
+--     return make_EInt (p->u.eInt_.integer_);
 -- <BLANKLINE>
 --   case is_EAdd:
 --     return make_EAdd
---       ( clone_Exp(p->u.eadd_.exp_1)
---       , clone_Exp(p->u.eadd_.exp_2)
+--       ( clone_Exp(p->u.eAdd_.exp_1)
+--       , clone_Exp(p->u.eAdd_.exp_2)
 --       );
 -- <BLANKLINE>
 --   default:
@@ -375,7 +375,7 @@ prCloneC (cat, rules)
   prCloneCat :: String -> (Cat, Doc) -> String
   prCloneCat fnm (cat, nt) = cloner cat member
     where
-    member = concat [ "p->u.", map toLower fnm, "_.", render nt ]
+    member = concat [ "p->u.", memName fnm, ".", render nt ]
 
 -- | Clone or not depending on the category.
 --   Only pointers need to be cloned.
@@ -401,8 +401,8 @@ cloner cat x =
 --     break;
 -- <BLANKLINE>
 --   case is_EAdd:
---     free_Exp(p->u.eadd_.exp_1);
---     free_Exp(p->u.eadd_.exp_2);
+--     free_Exp(p->u.eAdd_.exp_1);
+--     free_Exp(p->u.eAdd_.exp_2);
 --     break;
 -- <BLANKLINE>
 --   default:
@@ -482,8 +482,8 @@ prDestructorC (cat, rules)
   prFreeCat fnm (cat, nt) = Just $ concat
       [ maybe ("free_" ++ identCat (normCat cat)) (const "free") $ maybeTokenCat cat
       , "(p->u."
-      , map toLower fnm
-      , "_.", render nt, ");"
+      , memName fnm
+      , ".", render nt, ");"
       ]
 
 
@@ -614,21 +614,15 @@ prParams = zipWith prParam [1::Int ..]
     prParam n c = (text (identCat c), text ("p" ++ show n))
 
 -- | Prints the assignments of parameters to instance variables.
--- >>> prAssigns "A" [("A",1),("B",2)] [text "abc", text "def"]
+-- >>> prAssigns "A" [("A",1),("BA",2)] [text "abc", text "def"]
 -- tmp->u.a_.a_ = abc;
--- tmp->u.a_.b_2 = def;
+-- tmp->u.a_.ba_2 = def;
 prAssigns :: String -> [IVar] -> [Doc] -> Doc
 prAssigns c vars params = vcat $ zipWith prAssign vars params
   where
     prAssign (t,n) p =
-        text ("tmp->u." ++ c' ++ "_." ++ vname t n) <+> char '=' <+> p <> semi
+        text ("tmp->u." ++ memName c ++ "." ++ vname t n) <+> char '=' <+> p <> semi
     vname t n
       | n == 1, [_] <- filter ((t ==) . fst) vars
                   = varName t
       | otherwise = varName t ++ showNum n
-    c' = map toLower c
-
-{- **** Helper Functions **** -}
-
-memName :: String -> String
-memName s = map toLower s ++ "_"

source/src/BNFC/Backend/C/CFtoCPrinter.hs

@@ -33,7 +33,8 @@ import BNFC.Utils     ( (+++), uniqOn, unless, unlessNull )
 
 import BNFC.Backend.Common
 import BNFC.Backend.Common.NamedVariables
-import BNFC.Backend.Common.StrUtils (renderCharOrString)
+import BNFC.Backend.Common.StrUtils       ( renderCharOrString )
+import BNFC.Backend.C.Common              ( memName )
 
 -- | Produces (.h file, .c file).
 
@@ -446,7 +447,7 @@ prPrintRule r@(Rule fun _ _ _) = unless (isCoercion fun) $ concat
   where
     p   = precRule r
     fnm = funName fun
-    pre = concat [ "p->u.", map toLower fnm, "_." ]
+    pre = concat [ "p->u.", memName fnm, "." ]
 
 -- | Only render the rhs (items) of a rule.
 
@@ -567,8 +568,8 @@ prShowCat fnm (cat, nt) = concat
   [ "    sh"
   , maybe (identCat $ normCat cat) basicFunName $ maybeTokenCat cat
   , "(p->u."
-  , map toLower fnm
-  , "_."
+  , memName fnm
+  , "."
   , render nt
   , ");\n"
   ]

source/src/BNFC/Backend/C/CFtoCSkel.hs

@@ -19,6 +19,7 @@ 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 )
 
@@ -166,11 +167,11 @@ prData (cat, rules)
 
 -- | 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);
+-- >>> 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"
@@ -209,8 +210,7 @@ prCat fnm (cat, vname) =
       let visitf = "visit" <> if isTokenCat cat
                        then basicFunName cat
                        else text (identCat (normCat cat))
-      in visitf <> parens ("p->u." <> text v <> "_." <> vname ) <> ";"
-    where v = map toLower fnm
+      in visitf <> parens ("p->u." <> text (memName fnm) <> "." <> vname ) <> ";"
 
 -- | The visit-function name of a basic type
 

source/src/BNFC/Backend/C/Common.hs

@@ -1,10 +1,12 @@
 -- | Common definitions for the modules of the C backend.
 
 module BNFC.Backend.C.Common
-  ( posixC
+  ( memName
+  , posixC
   ) where
 
 import Prelude
+import BNFC.Backend.Common.NamedVariables
 
 -- | Switch C to language variant that has @strdup@.
 
@@ -16,3 +18,8 @@ posixC =
   , " */"
   , "#define _POSIX_C_SOURCE 200809L"
   ]
+
+-- | Variant names in unions.
+
+memName :: String -> String
+memName s = firstLowerCase s ++ "_"