diff --git a/.appveyor.yml b/.appveyor.yml index 41b50a4e..ce21cf1d 100644 --- a/.appveyor.yml +++ b/.appveyor.yml @@ -27,12 +27,9 @@ install: - "cabal --version" - "ghc --version" - "cabal %CABOPTS% v2-update -vverbose+nowrap" - - "cabal %CABOPTS% v2-install alex --bindir=/hsbin" - - "alex --version" build: off test_script: - "cd %APPVEYOR_BUILD_FOLDER%" - - "make sdist" - - "make sdist-test-only" + - "cabal %CABOPTS% v2-test happy -f -bootstrap" diff --git a/.github/haskell-ci.patch b/.github/haskell-ci.patch index 79e6de49..a558ef26 100644 --- a/.github/haskell-ci.patch +++ b/.github/haskell-ci.patch @@ -1,6 +1,14 @@ ---- workflows/haskell-ci.yml 2021-07-14 19:49:44.000000000 +0200 -+++ workflows/haskell-ci.yml-patched 2021-07-14 19:49:28.000000000 +0200 -@@ -196,7 +196,7 @@ +--- workflows/haskell-ci.yml ++++ workflows/haskell-ci.yml +@@ -107,6 +107,7 @@ jobs: + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" + HCDIR=/opt/$HCKIND/$HCVER + HC=$HCDIR/bin/$HCKIND ++ echo "$HCDIR/bin" >> "$GITHUB_PATH" + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" + echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" +@@ -226,7 +227,7 @@ jobs: cat cabal.project.local - name: dump install plan run: | @@ -9,19 +17,19 @@ cabal-plan - name: cache uses: actions/cache@v2 -@@ -206,17 +206,19 @@ +@@ -236,17 +237,25 @@ jobs: restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- - name: install dependencies run: | - $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all - $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all - - name: build w/o tests -+ $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all ++ $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests --dependencies-only -j2 all + $CABAL v2-build --flags=-bootstrap $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all + - name: build w/o tests and install run: | - $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all -+ $CABAL v2-install --reinstall --overwrite-policy=always --flags=-bootstrap $ARG_COMPILER --disable-tests --disable-benchmarks all ++ $CABAL v2-install --reinstall --overwrite-policy=always --flags=-bootstrap $ARG_COMPILER --disable-tests happy - name: build run: | - $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always @@ -30,14 +38,20 @@ run: | - $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + export HAPPY=$HOME/.cabal/bin/happy -+ export HC=$HC -+ $CABAL v2-test --flags=-bootstrap $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct ++ export HC ++ export CABAL ++ if [[ $(ghc --numeric-version) == "8.10.1" ]] ++ then ++ make sdist-test ++ else ++ $CABAL v2-test --flags=-bootstrap $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct ++ fi - name: cabal check run: | - cd ${PKGDIR_happy} || false -@@ -224,4 +226,4 @@ + cd ${PKGDIR_happy_frontend} || false +@@ -267,4 +276,4 @@ jobs: - name: unconstrained build run: | rm -f cabal.project.local - $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all -+ $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests --disable-benchmarks all ++ $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests all diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index c7513206..1058b09c 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -1,6 +1,6 @@ # This GitHub workflow config has been generated by a script via # -# haskell-ci 'github' 'happy.cabal' +# haskell-ci 'github' 'cabal.project' # # To regenerate the script (for example after adjusting tested-with) run # @@ -8,9 +8,9 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.13.20210606 +# version: 0.13.20210621 # -# REGENDATA ("0.13.20210606",["github","happy.cabal"]) +# REGENDATA ("0.13.20210621",["github","cabal.project"]) # name: Haskell-CI on: @@ -107,6 +107,7 @@ jobs: echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER HC=$HCDIR/bin/$HCKIND + echo "$HCDIR/bin" >> "$GITHUB_PATH" echo "HC=$HC" >> "$GITHUB_ENV" echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" @@ -169,7 +170,14 @@ jobs: - name: initial cabal.project for sdist run: | touch cabal.project - echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/frontend" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/tabular" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/backend" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/backend-glr" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/grammar" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/cli" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/test" >> cabal.project + echo "packages: $GITHUB_WORKSPACE/source/packages/happy" >> cabal.project cat cabal.project - name: sdist run: | @@ -181,17 +189,52 @@ jobs: find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; - name: generate cabal.project run: | + PKGDIR_happy_frontend="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-frontend-[0-9.]*')" + echo "PKGDIR_happy_frontend=${PKGDIR_happy_frontend}" >> "$GITHUB_ENV" + PKGDIR_happy_tabular="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-tabular-[0-9.]*')" + echo "PKGDIR_happy_tabular=${PKGDIR_happy_tabular}" >> "$GITHUB_ENV" + PKGDIR_happy_backend="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-backend-[0-9.]*')" + echo "PKGDIR_happy_backend=${PKGDIR_happy_backend}" >> "$GITHUB_ENV" + PKGDIR_happy_backend_glr="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-backend-glr-[0-9.]*')" + echo "PKGDIR_happy_backend_glr=${PKGDIR_happy_backend_glr}" >> "$GITHUB_ENV" + PKGDIR_happy_cli="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-cli-[0-9.]*')" + echo "PKGDIR_happy_cli=${PKGDIR_happy_cli}" >> "$GITHUB_ENV" + PKGDIR_happy_grammar="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-grammar-[0-9.]*')" + echo "PKGDIR_happy_grammar=${PKGDIR_happy_grammar}" >> "$GITHUB_ENV" + PKGDIR_happy_test="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-test-[0-9.]*')" + echo "PKGDIR_happy_test=${PKGDIR_happy_test}" >> "$GITHUB_ENV" PKGDIR_happy="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/happy-[0-9.]*')" echo "PKGDIR_happy=${PKGDIR_happy}" >> "$GITHUB_ENV" rm -f cabal.project cabal.project.local touch cabal.project touch cabal.project.local + echo "packages: ${PKGDIR_happy_frontend}" >> cabal.project + echo "packages: ${PKGDIR_happy_tabular}" >> cabal.project + echo "packages: ${PKGDIR_happy_backend}" >> cabal.project + echo "packages: ${PKGDIR_happy_backend_glr}" >> cabal.project + echo "packages: ${PKGDIR_happy_grammar}" >> cabal.project + echo "packages: ${PKGDIR_happy_cli}" >> cabal.project + echo "packages: ${PKGDIR_happy_test}" >> cabal.project echo "packages: ${PKGDIR_happy}" >> cabal.project + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy-frontend" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy-tabular" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy-backend" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy-backend-glr" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy-grammar" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy-cli" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy-test" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package happy" >> cabal.project ; fi if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi cat >> cabal.project <> cabal.project.local + $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(containers|happy|happy-backend|happy-backend-glr|happy-grammar|happy-cli|happy-frontend|happy-tabular|happy-test|mtl|transformers)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local - name: dump install plan @@ -206,24 +249,47 @@ jobs: restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- - name: install dependencies run: | - $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all + $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests --dependencies-only -j2 all $CABAL v2-build --flags=-bootstrap $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all - name: build w/o tests and install run: | - $CABAL v2-install --reinstall --overwrite-policy=always --flags=-bootstrap $ARG_COMPILER --disable-tests --disable-benchmarks all + $CABAL v2-install --reinstall --overwrite-policy=always --flags=-bootstrap $ARG_COMPILER --disable-tests happy - name: build run: | $CABAL v2-build --flags=-bootstrap $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always - name: tests run: | export HAPPY=$HOME/.cabal/bin/happy - export HC=$HC - $CABAL v2-test --flags=-bootstrap $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + export HC + export CABAL + if [[ $(ghc --numeric-version) == "8.10.1" ]] + then + make sdist-test + else + $CABAL v2-test --flags=-bootstrap $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + fi - name: cabal check run: | + cd ${PKGDIR_happy_frontend} || false + ${CABAL} -vnormal check + cd ${PKGDIR_happy_tabular} || false + ${CABAL} -vnormal check + cd ${PKGDIR_happy_backend} || false + ${CABAL} -vnormal check + cd ${PKGDIR_happy_backend_glr} || false + ${CABAL} -vnormal check + cd ${PKGDIR_happy_grammar} || false + ${CABAL} -vnormal check + cd ${PKGDIR_happy_cli} || false + ${CABAL} -vnormal check + cd ${PKGDIR_happy_test} || false + ${CABAL} -vnormal check cd ${PKGDIR_happy} || false ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all - name: unconstrained build run: | rm -f cabal.project.local - $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests --disable-benchmarks all + $CABAL v2-build --flags=-bootstrap $ARG_COMPILER --disable-tests all diff --git a/ChangeLog.md b/ChangeLog.md index 611525f3..af478e46 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## Unreleased - 1.21.0 + +- Split `happy` into multiple packages + ## 1.20.0 * Fix #121: the -i flag produces an .info file even if the `%expect` diff --git a/DEVELOPER.md b/DEVELOPER.md index 838c249e..81efb982 100644 --- a/DEVELOPER.md +++ b/DEVELOPER.md @@ -7,7 +7,7 @@ CI on GitHub Actions The GHC workflow file `.github/workflows/haskell-ci.yml` is generated by: - haskell-ci github happy.cabal + haskell-ci github packages/happy/happy.cabal patch --input=.github/haskell-ci.patch .github/workflows/haskell-ci.yml The patch introduces happy specifics to the build and test process that diff --git a/Makefile b/Makefile index 0956380b..12cf0ffa 100644 --- a/Makefile +++ b/Makefile @@ -1,48 +1,13 @@ -CABAL = cabal - -HAPPY_VER = `awk '/^version:/ { print $$2 }' happy.cabal` - -ALEX = alex -ALEX_OPTS = -g - -SDIST_DIR=dist-newstyle/sdist - -sdist :: - @case "`$(CABAL) --numeric-version`" in \ - 2.[2-9].* | [3-9].* ) ;; \ - * ) echo "Error: needs cabal 2.2.0.0 or later (but got : `$(CABAL) --numeric-version`)" ; exit 1 ;; \ - esac - @if [ "`git status -s`" != '' ]; then \ - echo "Error: Tree is not clean"; \ - exit 1; \ - fi - $(CABAL) v2-sdist - @if [ ! -f "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" ]; then \ - echo "Error: source tarball not found: dist/happy-$(HAPPY_VER).tar.gz"; \ - exit 1; \ - fi - git checkout . - git clean -f - -sdist-test :: sdist sdist-test-only - @rm -rf "${SDIST_DIR}/happy-${HAPPY_VER}/" - -sdist-test-only :: - @if [ ! -f "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" ]; then \ - echo "Error: source tarball not found: ${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz"; \ - exit 1; \ - fi - rm -rf "${SDIST_DIR}/happy-$(HAPPY_VER)/" - tar -xf "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" -C ${SDIST_DIR}/ - echo "packages: ." > "${SDIST_DIR}/happy-$(HAPPY_VER)/cabal.project" - echo "tests: True" >> "${SDIST_DIR}/happy-$(HAPPY_VER)/cabal.project" - cd "${SDIST_DIR}/happy-$(HAPPY_VER)/" \ - && cabal v2-build all --flag -bootstrap \ - && cabal v2-install --flag -bootstrap --installdir="./bootstrap-root" \ - && cabal v2-test all -j --flag -bootstrap \ - && export PATH=./bootstrap-root:$$PATH \ - && cabal v2-build all --flag +bootstrap \ - && cabal v2-test all -j --flag +bootstrap - @echo "" - @echo "Success! ${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz is ready for distribution!" - @echo "" +ENV = .local.env +HC ?= ghc +CABAL ?= cabal + +EXECUTABLE = "happy" +PACKAGES = ["happy", "happy-cli", "happy-grammar", "happy-frontend", "happy-tabular", "happy-backend", "happy-test"] +BOOTSTRAPPING = True + +sdist-test :: + rm -f ${ENV} + $(CABAL) v2-install --lib happy-test --package-env ${ENV} + $(HC) -package-env ${ENV} -e 'Happy.Test.SDist.sdist_test "${CABAL}" "$(shell pwd)" ${EXECUTABLE} ${PACKAGES} ${BOOTSTRAPPING}' + rm -f ${ENV} diff --git a/README.md b/README.md index f9128ef5..ea284f4c 100644 --- a/README.md +++ b/README.md @@ -11,12 +11,11 @@ Happy is a parser generator for Haskell 98 (and later). Happy is built using Cabal. First install GHC, then: ``` - $ cabal install + $ cabal install happy ``` -If you obtained the development version from https://github.com/simonmar/happy/, -install via: +If you don't have a local version of `happy` (yet), you can also install a non-bootstrapped version via: ``` - $ make sdist && cabal install + $ cabal install happy -f -bootstrap ``` Complete documentation can be found in the directory 'doc', in diff --git a/build-windows-dist.sh b/build-windows-dist.sh deleted file mode 100644 index 0747f27f..00000000 --- a/build-windows-dist.sh +++ /dev/null @@ -1,18 +0,0 @@ -# mini script for building the relocatable Windows binary distribution. -# -# sh build-windows-dist.sh -# -# NB. the Cabal that shipped with GHC 6.6 isn't enough for this, because it -# is missing this patch: -# -# Fri Oct 13 11:09:41 BST 2006 Simon Marlow -# * Fix getDataDir etc. when bindir=$prefix -# -# So you need to use a more recent Cabal. GHC 6.6 is fine for building the -# package, though. - -ghc --make Setup -./Setup configure --prefix=`pwd`/install --bindir='$prefix' --libdir='$prefix' --datadir='$prefix' -./Setup build -./Setup install -echo Now zip up `pwd`/install as "happy--Win32.zip" diff --git a/cabal.project b/cabal.project index 8834d044..83f3594f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,9 @@ packages: - ./ + packages/backend, + packages/backend-glr, + packages/cli, + packages/frontend, + packages/grammar, + packages/happy, + packages/tabular, + packages/test \ No newline at end of file diff --git a/examples/Calc.ly b/examples/Calc.ly index 06b34902..94d0db90 100644 --- a/examples/Calc.ly +++ b/examples/Calc.ly @@ -1,6 +1,6 @@ > { > module Calc where -> import Char +> import Data.Char > } First thing to declare is the name of your parser, diff --git a/examples/ErrorTest.ly b/examples/ErrorTest.ly index 80f5564e..d302802d 100644 --- a/examples/ErrorTest.ly +++ b/examples/ErrorTest.ly @@ -2,7 +2,7 @@ Test for monadic Happy Parsers, Simon Marlow 1996. > { -> import Char +> import Data.Char > } > %name calc diff --git a/examples/LexerTest.ly b/examples/LexerTest.ly index 889fc85a..60866415 100644 --- a/examples/LexerTest.ly +++ b/examples/LexerTest.ly @@ -2,7 +2,7 @@ Test for monadic Happy Parsers, Simon Marlow 1996. > { -> import Char +> import Data.Char > } > %name calc diff --git a/examples/MonadTest.ly b/examples/MonadTest.ly index 94553046..a5f83a26 100644 --- a/examples/MonadTest.ly +++ b/examples/MonadTest.ly @@ -2,7 +2,7 @@ Tests %monad without %lexer. > { -> import Char +> import Data.Char > } > %name calc diff --git a/packages/backend-glr/LICENSE b/packages/backend-glr/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/backend-glr/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/Setup.hs b/packages/backend-glr/Setup.hs similarity index 100% rename from Setup.hs rename to packages/backend-glr/Setup.hs diff --git a/data/GLR_Base.hs b/packages/backend-glr/data/GLR_Base.hs similarity index 100% rename from data/GLR_Base.hs rename to packages/backend-glr/data/GLR_Base.hs diff --git a/data/GLR_Lib.hs b/packages/backend-glr/data/GLR_Lib.hs similarity index 100% rename from data/GLR_Lib.hs rename to packages/backend-glr/data/GLR_Lib.hs diff --git a/packages/backend-glr/happy-backend-glr.cabal b/packages/backend-glr/happy-backend-glr.cabal new file mode 100644 index 00000000..9f206d5a --- /dev/null +++ b/packages/backend-glr/happy-backend-glr.cabal @@ -0,0 +1,56 @@ +name: happy-backend-glr +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: A GLR backend for happy + +Description: + Happy is a parser generator for Haskell. + Happy-Backend-GLR is a backend which creates + GLR-based Haskell code. + + +tested-with: + GHC == 7.0.4 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +data-dir: data + +data-files: + GLR_Base.hs + GLR_Lib.hs + +library + hs-source-dirs: src + + exposed-modules: Happy.Backend.GLR, + Happy.Backend.GLR.CLI + build-depends: base < 5, + array, + happy-grammar == 1.21.0, + happy-tabular == 1.21.0 + + default-language: Haskell98 + default-extensions: CPP, MagicHash, FlexibleContexts + ghc-options: -Wall + other-modules: Happy.Backend.GLR.ProduceCode, + Paths_happy_backend_glr diff --git a/packages/backend-glr/src/Happy/Backend/GLR.hs b/packages/backend-glr/src/Happy/Backend/GLR.hs new file mode 100644 index 00000000..e19c6318 --- /dev/null +++ b/packages/backend-glr/src/Happy/Backend/GLR.hs @@ -0,0 +1,58 @@ +module Happy.Backend.GLR(GLRBackendArgs(..), runGLRBackend) where + +import Prelude hiding (filter) +import Happy.Backend.GLR.ProduceCode +import Happy.Grammar.Grammar +import Happy.Tabular.Tables +import Paths_happy_backend_glr +import Data.Maybe + +-------- Main entry point (runGLRBackend) -------- + +data GLRBackendArgs = GLRBackendArgs { + outFile :: String, + templateDir :: Maybe String, + decode :: Bool, + filter :: Bool, + ghc :: Bool, + debug :: Bool +} + +runGLRBackend :: GLRBackendArgs -> Grammar -> ActionTable -> GotoTable -> IO () +runGLRBackend args g action goto = do + defaultDir <- getDataDir + let header = fromMaybe "" (hd g) ++ importsToInject args + let templateDir' = fromMaybe defaultDir (templateDir args) + produceCode args g action goto header templateDir' + +-------- Helpers -------- + +produceCode :: GLRBackendArgs -> Grammar -> ActionTable -> GotoTable -> String -> String -> IO () +produceCode args g action goto header template_dir = do + let glr_decode = if decode args then TreeDecode else LabelDecode + filtering = if filter args then UseFiltering else NoFiltering + ghc_exts = if ghc args then UseGhcExts (importsToInject args) (langExtsToInject args) else NoGhcExts -- Don't always pass CPP, because only one of the files needs it. + produceGLRParser (outFile args) template_dir action goto (Just header) (tl g) (debug args, (glr_decode, filtering, ghc_exts)) g + +importsToInject :: GLRBackendArgs -> String +importsToInject args = concat ["\n", import_array, import_bits, glaexts_import, debug_imports, applicative_imports] + where + glaexts_import | ghc args = import_glaexts + | otherwise = "" + debug_imports | debug args = import_debug + | otherwise = "" + applicative_imports = import_applicative + + import_glaexts = "import qualified GHC.Exts as Happy_GHC_Exts\n" + import_array = "import qualified Data.Array as Happy_Data_Array\n" + import_bits = "import qualified Data.Bits as Bits\n" + import_debug = "import qualified System.IO as Happy_System_IO\n" ++ + "import qualified System.IO.Unsafe as Happy_System_IO_Unsafe\n" ++ + "import qualified Debug.Trace as Happy_Debug_Trace\n" + import_applicative = "import Control.Applicative(Applicative(..))\n" ++ + "import Control.Monad (ap)\n" + +langExtsToInject :: GLRBackendArgs -> [String] +langExtsToInject args + | ghc args = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances"] + | otherwise = [] \ No newline at end of file diff --git a/packages/backend-glr/src/Happy/Backend/GLR/CLI.hs b/packages/backend-glr/src/Happy/Backend/GLR/CLI.hs new file mode 100644 index 00000000..9b369eb9 --- /dev/null +++ b/packages/backend-glr/src/Happy/Backend/GLR/CLI.hs @@ -0,0 +1,46 @@ +module Happy.Backend.GLR.CLI(Flag(..), options, parseFlags) where + +import Prelude hiding (filter) +import Happy.Backend.GLR +import System.Console.GetOpt + +-------- CLI flags and options -------- + +data Flag = + OptOutputFile String | + OptTemplate String | + OptDecode | + OptFilter | + OptGhcTarget | + OptDebugParser + deriving Eq + +options :: [OptDescr Flag] +options = [ + Option "o" ["outfile"] (ReqArg OptOutputFile "FILE") "write the output to FILE (default: file.hs)", + Option "t" ["template"] (ReqArg OptTemplate "DIR") "look in DIR for template files", + Option "k" ["decode"] (NoArg OptDecode) "Generate simple decoding code for GLR result", + Option "f" ["filter"] (NoArg OptFilter) "Filter the GLR parse forest with respect to semantic usage", + Option "g" ["ghc"] (NoArg OptGhcTarget) "use GHC extensions", + Option "d" ["debug"] (NoArg OptDebugParser) "produce a debugging parser" + ] + +parseFlags :: [Flag] -> String -> GLRBackendArgs +parseFlags cli baseName = GLRBackendArgs { + outFile = getOutputFileName baseName cli, + templateDir = getTemplate cli, + decode = OptDecode `elem` cli, + filter = OptFilter `elem` cli, + ghc = OptGhcTarget `elem` cli, + debug = OptDebugParser `elem` cli + } + +getOutputFileName :: String -> [Flag] -> String +getOutputFileName base cli = case [ s | (OptOutputFile s) <- cli ] of + [] -> base ++ ".hs" + list -> last list + +getTemplate :: [Flag] -> Maybe String +getTemplate cli = case [ s | (OptTemplate s) <- cli ] of + [] -> Nothing + list -> Just $ last list \ No newline at end of file diff --git a/src/ProduceGLRCode.lhs b/packages/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs similarity index 97% rename from src/ProduceGLRCode.lhs rename to packages/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs index da4fe566..f1302465 100644 --- a/src/ProduceGLRCode.lhs +++ b/packages/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs @@ -7,17 +7,17 @@ This module is designed as an extension to the Haskell parser generator Happy. -- extension to semantic rules, and various optimisations %----------------------------------------------------------------------------- -> module ProduceGLRCode ( produceGLRParser +> module Happy.Backend.GLR.ProduceCode +> ( produceGLRParser > , DecodeOption(..) > , FilterOption(..) > , GhcExts(..) > , Options > ) where -> import Paths_happy ( version ) -> import GenUtils ( mapDollarDollar ) -> import GenUtils ( str, char, nl, brack, brack', interleave, maybestr ) -> import Grammar +> import Paths_happy_backend_glr ( version ) +> import Happy.Grammar.Grammar +> import Happy.Tabular.Tables > import Data.Array ( Array, (!), array, assocs ) > import Data.Char ( isSpace, isAlphaNum ) > import Data.List ( nub, (\\), sort, find, tails ) @@ -739,3 +739,25 @@ remove Happy-generated start symbols. > mkHappyVar :: Int -> String -> String > mkHappyVar n = str "happy_var_" . shows n + +%------------------------------------------------------------------------------ +Fast string-building functions + +> str :: String -> String -> String +> str = showString +> char :: Char -> String -> String +> char c = (c :) +> interleave :: String -> [String -> String] -> String -> String +> interleave s = foldr (\a b -> a . str s . b) id + +> nl :: String -> String +> nl = char '\n' + +> maybestr :: Maybe String -> String -> String +> maybestr (Just s) = str s +> maybestr _ = id + +> brack :: String -> String -> String +> brack s = str ('(' : s) . char ')' +> brack' :: (String -> String) -> String -> String +> brack' s = char '(' . s . char ')' diff --git a/packages/backend/LICENSE b/packages/backend/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/backend/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/packages/backend/Setup.hs b/packages/backend/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/backend/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/HappyTemplate.hs b/packages/backend/data/HappyTemplate.hs similarity index 100% rename from data/HappyTemplate.hs rename to packages/backend/data/HappyTemplate.hs diff --git a/packages/backend/happy-backend.cabal b/packages/backend/happy-backend.cabal new file mode 100644 index 00000000..4a1caffc --- /dev/null +++ b/packages/backend/happy-backend.cabal @@ -0,0 +1,57 @@ +name: happy-backend +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: A table-based backend for happy + +Description: + Happy is a parser generator for Haskell. + Happy-Backend is responsible for code-generation: + It converts action and goto tables into Haskell code. + + +tested-with: + GHC == 7.0.4 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +data-dir: data + +data-files: + HappyTemplate.hs + +library + hs-source-dirs: src + + exposed-modules: Happy.Backend, + Happy.Backend.CLI + build-depends: base < 5, + array, + happy-cli == 1.21.0, + happy-grammar == 1.21.0, + happy-tabular == 1.21.0 + + default-language: Haskell98 + default-extensions: CPP, MagicHash, FlexibleContexts + ghc-options: -Wall + other-modules: Happy.Backend.Target, + Happy.Backend.ProduceCode, + Paths_happy_backend diff --git a/packages/backend/src/Happy/Backend.hs b/packages/backend/src/Happy/Backend.hs new file mode 100644 index 00000000..4d087b59 --- /dev/null +++ b/packages/backend/src/Happy/Backend.hs @@ -0,0 +1,84 @@ +module Happy.Backend(BackendArgs(..), Target(..), runBackend) where + +import Happy.Backend.Target +import Happy.Backend.ProduceCode +import Happy.Grammar.Grammar +import Happy.Tabular.Tables +import Paths_happy_backend +import Data.Char +import Data.Maybe + +-------- Main entry point (runBackend) -------- + +data BackendArgs = BackendArgs { + outFile :: String, + templateDir :: Maybe String, + magicName :: Maybe String, + strict :: Bool, + ghc :: Bool, + coerce :: Bool, -- requires ghc + target :: Target, + debug :: Bool -- requires target = TargetArrayBased +} + +runBackend :: BackendArgs -> Grammar -> ActionTable -> GotoTable -> IO () +runBackend args g action goto = do + defaultDir <- getDataDir + let header = fromMaybe "" (hd g) ++ importsToInject args + let templateDir' = fromMaybe defaultDir (templateDir args) + produceCode args g action goto header templateDir' + +-------- Helpers -------- + +produceCode :: BackendArgs -> Grammar -> ActionTable -> GotoTable -> String -> String -> IO () +produceCode args g action goto header template_dir = do + template <- readFile (template_dir ++ "/HappyTemplate.hs") + let outfile = produceParser g action goto ("CPP" : langExtsToInject args) -- CPP is needed in all cases with unified template + (Just header) (tl g) (target args) (coerce args) (ghc args) (strict args) + let write = (if outFile args == "-" then putStr else writeFile $ outFile args) + write $ magicFilter args (outfile ++ defines args ++ template) + +magicFilter :: BackendArgs -> String -> String +magicFilter args = case magicName args of + Nothing -> id + Just name' -> let + small_name = name' + big_name = toUpper (head name') : tail name' + filter_output ('h':'a':'p':'p':'y':rest) = small_name ++ filter_output rest + filter_output ('H':'a':'p':'p':'y':rest) = big_name ++ filter_output rest + filter_output (c:cs) = c : filter_output cs + filter_output [] = [] + in filter_output + +importsToInject :: BackendArgs -> String +importsToInject args = concat ["\n", import_array, import_bits, glaexts_import, debug_imports, applicative_imports] + where + glaexts_import | ghc args = import_glaexts + | otherwise = "" + debug_imports | debug args = import_debug + | otherwise = "" + applicative_imports = import_applicative + + import_glaexts = "import qualified GHC.Exts as Happy_GHC_Exts\n" + import_array = "import qualified Data.Array as Happy_Data_Array\n" + import_bits = "import qualified Data.Bits as Bits\n" + import_debug = "import qualified System.IO as Happy_System_IO\n" ++ + "import qualified System.IO.Unsafe as Happy_System_IO_Unsafe\n" ++ + "import qualified Debug.Trace as Happy_Debug_Trace\n" + import_applicative = "import Control.Applicative(Applicative(..))\n" ++ + "import Control.Monad (ap)\n" + +langExtsToInject :: BackendArgs -> [String] +langExtsToInject args + | ghc args = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances"] + | otherwise = [] + +defines :: BackendArgs -> String +defines args = unlines [ "#define " ++ d ++ " 1" | d <- vars_to_define ] + where + vars_to_define = concat + [ [ "HAPPY_DEBUG" | debug args ] + , [ "HAPPY_ARRAY" | target args == TargetArrayBased ] + , [ "HAPPY_GHC" | ghc args ] + , [ "HAPPY_COERCE" | coerce args ] + ] \ No newline at end of file diff --git a/packages/backend/src/Happy/Backend/CLI.hs b/packages/backend/src/Happy/Backend/CLI.hs new file mode 100644 index 00000000..17d5c232 --- /dev/null +++ b/packages/backend/src/Happy/Backend/CLI.hs @@ -0,0 +1,95 @@ +module Happy.Backend.CLI(Flag(..), options, parseFlags, parseAndRun) where + +import Happy.Backend +import Happy.CLI.Dying +import Happy.Grammar.Grammar +import Happy.Tabular.Tables +import System.Console.GetOpt +import Data.Char + +-------- CLI flags and options -------- + +data Flag = + OptOutputFile String | + OptTemplate String | + OptMagicName String | + OptStrict | + OptGhcTarget | + OptUseCoercions | + OptArrayTarget | + OptDebugParser + deriving Eq + +options :: [OptDescr Flag] +options = [ + Option "o" ["outfile"] (ReqArg OptOutputFile "FILE") "write the output to FILE (default: file.hs)", + Option "t" ["template"] (ReqArg OptTemplate "DIR") "look in DIR for template files", + Option "m" ["magic-name"] (ReqArg OptMagicName "NAME") "use NAME as the symbol prefix instead of \"happy\"", + Option "s" ["strict"] (NoArg OptStrict) "evaluate semantic values strictly (experimental)", + Option "g" ["ghc"] (NoArg OptGhcTarget) "use GHC extensions", + Option "c" ["coerce"] (NoArg OptUseCoercions) "use type coercions (only available with -g)", + Option "a" ["array"] (NoArg OptArrayTarget) "generate an array-based parser", + Option "d" ["debug"] (NoArg OptDebugParser) "produce a debugging parser (only with -a)" + ] + +-------- [Flag] to BackendArgs conversion -------- + +parseAndRun :: [Flag] -> String -> Grammar -> ActionTable -> GotoTable -> IO () +parseAndRun flags basename grammar action goto = (parseFlags flags basename) >>= (\args -> runBackend args grammar action goto) + +parseFlags :: [Flag] -> String -> IO BackendArgs +parseFlags cli baseName = do + target' <- getTarget cli + coerce' <- getCoerce cli + debug' <- getDebug cli + return BackendArgs { + outFile = getOutputFileName baseName cli, + templateDir = getTemplate cli, + magicName = getMagicName cli, + strict = OptStrict `elem` cli, + ghc = OptGhcTarget `elem` cli, + coerce = coerce', + target = target', + debug = debug' + } + +getTarget :: [Flag] -> IO Target +getTarget cli = case [ t | (Just t) <- map optToTarget cli ] of + (t:ts) | all (==t) ts -> return t + [] -> return TargetHaskell + _ -> dieHappy "multiple target options\n" + +optToTarget :: Flag -> Maybe Target +optToTarget OptArrayTarget = Just TargetArrayBased +optToTarget _ = Nothing + +getOutputFileName :: String -> [Flag] -> String +getOutputFileName base cli = case [ s | (OptOutputFile s) <- cli ] of + [] -> base ++ ".hs" + list -> last list + +getTemplate :: [Flag] -> Maybe String +getTemplate cli = case [ s | (OptTemplate s) <- cli ] of + [] -> Nothing + list -> Just $ last list + +getMagicName :: [Flag] -> Maybe String +getMagicName cli = case [ s | (OptMagicName s) <- cli ] of + [] -> Nothing + list -> (Just (map toLower (last list))) + +getCoerce :: [Flag] -> IO Bool +getCoerce cli + | elem OptUseCoercions cli = + if elem OptGhcTarget cli + then return True + else dieHappy "-c/--coerce may only be used in conjunction with -g/--ghc\n" + | otherwise = return False + +getDebug :: [Flag] -> IO Bool +getDebug cli + | elem OptDebugParser cli = + if elem OptArrayTarget cli + then return True + else dieHappy "-d/--debug may only be used in conjunction with -a/--array\n" + | otherwise = return False \ No newline at end of file diff --git a/src/ProduceCode.lhs b/packages/backend/src/Happy/Backend/ProduceCode.lhs similarity index 98% rename from src/ProduceCode.lhs rename to packages/backend/src/Happy/Backend/ProduceCode.lhs index fe627c9c..57ca8369 100644 --- a/src/ProduceCode.lhs +++ b/packages/backend/src/Happy/Backend/ProduceCode.lhs @@ -4,19 +4,17 @@ The code generator. (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- -> module ProduceCode (produceParser) where +> module Happy.Backend.ProduceCode (produceParser) where -> import Paths_happy ( version ) -> import Data.Version ( showVersion ) -> import Grammar -> import Target ( Target(..) ) -> import GenUtils ( mapDollarDollar, str, char, nl, strspace, -> interleave, interleave', maybestr, -> brack, brack' ) +> import Paths_happy_backend ( version ) +> import Happy.Backend.Target ( Target(..) ) +> import Happy.Grammar.Grammar +> import Happy.Tabular.Tables > import Data.Maybe ( isJust, isNothing, fromMaybe ) > import Data.Char ( ord, chr ) > import Data.List ( sortBy ) +> import Data.Version ( showVersion ) > import Control.Monad ( forM_ ) > import Control.Monad.ST ( ST, runST ) @@ -1409,6 +1407,32 @@ slot is free or not. > specReduceFun :: Int -> Bool > specReduceFun = (<= 3) +------------------------------------------------------------------------------- +-- Fast string-building functions. + +> str :: String -> String -> String +> str = showString +> char :: Char -> String -> String +> char c = (c :) +> interleave :: String -> [String -> String] -> String -> String +> interleave s = foldr (\a b -> a . str s . b) id +> interleave' :: String -> [String -> String] -> String -> String +> interleave' s = foldr1 (\a b -> a . str s . b) + +> strspace :: String -> String +> strspace = char ' ' +> nl :: String -> String +> nl = char '\n' + +> maybestr :: Maybe String -> String -> String +> maybestr (Just s) = str s +> maybestr _ = id + +> brack :: String -> String -> String +> brack s = str ('(' : s) . char ')' +> brack' :: (String -> String) -> String -> String +> brack' s = char '(' . s . char ')' + ----------------------------------------------------------------------------- -- Convert an integer to a 16-bit number encoded in \xNN\xNN format suitable -- for placing in a string. diff --git a/src/Target.lhs b/packages/backend/src/Happy/Backend/Target.lhs similarity index 88% rename from src/Target.lhs rename to packages/backend/src/Happy/Backend/Target.lhs index f08d90d2..08e150d4 100644 --- a/src/Target.lhs +++ b/packages/backend/src/Happy/Backend/Target.lhs @@ -4,7 +4,7 @@ The target data type. (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- -> module Target (Target(..)) where +> module Happy.Backend.Target (Target(..)) where > data Target > = TargetHaskell -- functions and things diff --git a/packages/cli/LICENSE b/packages/cli/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/cli/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/packages/cli/Setup.hs b/packages/cli/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/cli/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/packages/cli/happy-cli.cabal b/packages/cli/happy-cli.cabal new file mode 100644 index 00000000..8b8f9f1a --- /dev/null +++ b/packages/cli/happy-cli.cabal @@ -0,0 +1,45 @@ +name: happy-cli +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: Option parsing functionality of happy + +Description: + Happy is a parser generator for Haskell. + Happy-CLI provides functionality related to centralised option parsing, + which can be used sensibly from within a happy executable package. + +tested-with: + GHC == 7.0.4 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +library + hs-source-dirs: src + + exposed-modules: Happy.CLI.OptionParsing, + Happy.CLI.Dying + build-depends: base < 5 + + default-language: Haskell98 + default-extensions: CPP, MagicHash, FlexibleContexts + ghc-options: -Wall + other-modules: diff --git a/packages/cli/src/Happy/CLI/Dying.hs b/packages/cli/src/Happy/CLI/Dying.hs new file mode 100644 index 00000000..831fc72c --- /dev/null +++ b/packages/cli/src/Happy/CLI/Dying.hs @@ -0,0 +1,37 @@ +module Happy.CLI.Dying (die, dieUsage, dieHappy, bye, byeUsage, getProgramName, usageHeader) where + +import System.Console.GetOpt +import System.Environment +import System.Exit (exitWith, ExitCode(..)) +import Control.Monad (liftM) +import Data.List (isSuffixOf) + +#if MIN_VERSION_base(4,8,0) +import System.Exit (die) +#else +import System.IO +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) +#endif + +dieHappy :: String -> IO a +dieHappy s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) + +bye :: String -> IO a +bye s = putStr s >> exitWith ExitSuccess + +byeUsage :: [OptDescr a] -> String -> IO b +byeUsage opts s = getProgramName >>= bye . (s ++) . usageHeader opts + +dieUsage :: [OptDescr a] -> String -> IO b +dieUsage opts s = getProgramName >>= die . (s ++) . usageHeader opts + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str' `withoutSuffix` suff + | suff `isSuffixOf` str' = take (length str' - length suff) str' + | otherwise = str' + +usageHeader :: [OptDescr a] -> String -> String +usageHeader opts prog = usageInfo header opts where + header = "Usage: " ++ prog ++ " [OPTION...] file\n" \ No newline at end of file diff --git a/packages/cli/src/Happy/CLI/OptionParsing.hs b/packages/cli/src/Happy/CLI/OptionParsing.hs new file mode 100644 index 00000000..dfb99841 --- /dev/null +++ b/packages/cli/src/Happy/CLI/OptionParsing.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE ExplicitForAll #-} + +module Happy.CLI.OptionParsing( + parseOptions, beginOptionsWith, requireUnnamedArgument, OnNone(..), OnMultiple(..), + removeAllOverlaps, removeLongOption, removeLongOverlaps, cleanShortOption, cleanShortOverlaps, +) where + +import System.Console.GetOpt +import Data.List (sort, sortBy, group, intersect, elemIndex, intersect, delete) +import Data.Ord +import Data.Maybe +import Data.Version (showVersion, Version) +import Happy.CLI.Dying + +-------- Flag definitions and standard options -------- + +data Flag cli = + Fixed FixedFlag | -- Flags that are always present in any happy + Custom cli -- Flags that come from the specific packages that are used + deriving Eq + +data FixedFlag = + DumpVersion | + DumpHelp + deriving Eq + +fixedOpts :: [OptDescr (Flag cli)] +fixedOpts = [ + Option "?" ["help"] (NoArg (Fixed DumpHelp)) "display this help and exit", + Option "Vv" ["version"] (NoArg (Fixed DumpVersion)) "output version information and exit" + ] + +addFixed :: [OptDescr cli] -> [OptDescr (Flag cli)] +addFixed customOpts = map (fmap Custom) customOpts ++ fixedOpts + +-------- Parsing -------- + +-- Returns all matched flags and the list of unnamed arguments +parseOptions :: Eq cli => [OptDescr cli] -> Version -> [String] -> IO ([cli], [String]) +parseOptions customOpts version args = + let options = addFixed customOpts in do + checkDuplicateOptions options + case getOpt Permute options args of + (cli, _, []) | elem (Fixed DumpVersion) cli -> + bye (copyright version) + + (cli, _, []) | elem (Fixed DumpHelp) cli -> + byeUsage options "" + + (cli, freeOpts, []) -> do + let customFlags = [a | Custom a <- cli] + return (customFlags, freeOpts) + + (_, _, errors) -> + dieUsage options (concat errors) + +-- Requires the list of unnamed arguments to consist of at least one element, else show usage info and optionally an error. +requireUnnamedArgument :: [String] -> [OptDescr a] -> OnNone -> OnMultiple -> IO String +requireUnnamedArgument args customOpts onNone onMultiple = + let options = addFixed customOpts in + case (length args, onNone, onMultiple) of + (0, DieUsage0, _) -> dieUsage options "" + (0, DieError0, IsOkayMult) -> dieUsage options "Provide at least one unnamed argument.\n" + (0, DieError0, _) -> dieUsage options "Provide one unnamed argument.\n" + (1, _, _) -> return (head args) + (_, _, IsOkayMult) -> return (head args) + (_, _, DieUsageMult) -> dieUsage options "" + (_, _, DieErrorMult) -> dieUsage options "Provide exactly one unnamed argument.\n" + +data OnNone = DieUsage0 | DieError0 +data OnMultiple = IsOkayMult | DieUsageMult | DieErrorMult + +-- Sort the options by the list of given short option characters. +-- Options which do not have any of these short option characters come after the sorted options which have been matched. +beginOptionsWith :: [Char] -> [OptDescr a] -> [OptDescr a] +beginOptionsWith chars opts = sortBy (comparing $ smallestIndex . shorts) matched ++ nonMatched + where + smallestIndex :: [Char] -> Int + smallestIndex a = minimum (map (fromMaybe 1000 . flip elemIndex chars) a) + matched = filter (not . null . intersect chars . shorts) opts + nonMatched = filter (null . intersect chars . shorts) opts + +-------- Option Conflicts -------- + +-- Combine removeLongOverlaps with cleanShortOverlaps +removeAllOverlaps :: [OptDescr a] -> [OptDescr b] -> [OptDescr b] +removeAllOverlaps a = removeLongOverlaps a . cleanShortOverlaps a + +-- Remove a long option from the list of options, if existing. +-- This means: any option which features this long option string is removed (even if it has multiple different long option strings). +removeLongOption :: String -> [OptDescr a] -> [OptDescr a] +removeLongOption long opts = filter (not . elem long . longs) opts + +-- Remove all overlaps with the first list's long option strings from the second list (using removeLongOption). +removeLongOverlaps :: [OptDescr a] -> [OptDescr b] -> [OptDescr b] +removeLongOverlaps a b = foldr removeLongOption b (concatMap longs a) + +-- Remove a short option from the list of options, if existing. +-- In contrast to `removeLongOption`, a matching short option character will just be removed +-- from its hosting option – the option itself remains, provided it features at least one other short or long option. +cleanShortOption :: Char -> [OptDescr a] -> [OptDescr a] +cleanShortOption short opts = filter nonempty $ map remove opts where + remove (Option s a b c) = Option (delete short s) a b c + +-- Remove all overlaps with the first list's short option strings from the second list (using cleanShortOption). +cleanShortOverlaps :: [OptDescr a] -> [OptDescr b] -> [OptDescr b] +cleanShortOverlaps a b = foldr cleanShortOption b (concatMap shorts a) + +shorts :: OptDescr a -> [Char] +longs :: OptDescr a -> [String] +nonempty :: OptDescr a -> Bool +shorts (Option s _ _ _) = s +longs (Option _ l _ _) = l +nonempty (Option s l _ _) = not (null s) || not (null l) + +-------- Internal helpers -------- + +checkDuplicateOptions :: [OptDescr a] -> IO () +checkDuplicateOptions opts = case (multiples (concatMap shorts opts), multiples (concatMap longs opts)) of + (x:_, _) -> die $ "Attention: option -" ++ x : " corresponds to multiple different arguments; please fix this.\n" + (_, x:_) -> die $ "Attention: option --" ++ x ++ " corresponds to multiple different arguments; please fix this.\n" + _ -> return () + where + multiples :: Ord a => [a] -> [a] + multiples = map head . filter ((> 1) . length) . group . sort + +copyright :: Version -> String +copyright version = unlines [ + "Happy Version " ++ showVersion version ++ " Copyright (c) 1993-1996 Andy Gill, Simon Marlow (c) 1997-2005 Simon Marlow","", + "Happy is a Yacc for Haskell, and comes with ABSOLUTELY NO WARRANTY.", + "This program is free software; you can redistribute it and/or modify", + "it under the terms given in the file 'LICENSE' distributed with", + "the Happy sources."] + +-- (Functor OptDescr) only exists since base-4.7.0.0, i.e. GHC 7.8.1 +-- In the doc, it says (Functor OptDescr) exists since base-4.6.0.0, but that seems to be wrong +#if !MIN_VERSION_base(4,7,0) +instance Functor OptDescr where + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + +instance Functor ArgDescr where + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (f . g) s + fmap f (OptArg g s) = OptArg (f . g) s +#endif \ No newline at end of file diff --git a/packages/frontend/LICENSE b/packages/frontend/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/frontend/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/packages/frontend/Setup.hs b/packages/frontend/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/frontend/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/packages/frontend/happy-frontend.cabal b/packages/frontend/happy-frontend.cabal new file mode 100644 index 00000000..66873789 --- /dev/null +++ b/packages/frontend/happy-frontend.cabal @@ -0,0 +1,82 @@ +name: happy-frontend +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: A yacc-like frontend for happy + +Description: + Happy is a parser generator for Haskell. + Happy-Frontend is responsible for parsing .y- and .ly-files + and mangling them into a Grammar datatype. + These .y- and .ly-files work similar to yacc's .y-files, but + have some Haskell-specific features. + +tested-with: + GHC == 7.0.4 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +flag bootstrap + description: Optimize the implementation of happy using a pre-built happy + manual: True + default: True + +library + hs-source-dirs: src + exposed-modules: Happy.Frontend, + Happy.Frontend.CLI, + Happy.Frontend.AbsSyn + + build-depends: base < 5, + array, + containers >= 0.4.2, + transformers >= 0.5.6.2, + mtl >= 2.2.2, + happy-cli == 1.21.0, + happy-grammar == 1.21.0 + + default-language: Haskell98 + default-extensions: CPP, MagicHash, FlexibleContexts + ghc-options: -Wall + other-modules: + Happy.Frontend.Mangler + Happy.Frontend.Lexer + Happy.Frontend.ParseMonad + Happy.Frontend.ParseMonad.Class + Happy.Frontend.Parser + Happy.Frontend.AttrGrammar + Happy.Frontend.ParamRules + Happy.Frontend.PrettyGrammar + + if flag(bootstrap) + -- TODO put this back when Cabal can use it's qualified goals to better + -- understand bootstrapping, see + -- https://github.com/haskell/cabal/issues/7189 + --build-tools: happy + cpp-options: -DHAPPY_BOOTSTRAP + other-modules: + Happy.Frontend.ParseMonad.Bootstrapped + Happy.Frontend.Parser.Bootstrapped + Happy.Frontend.AttrGrammar.Parser + else + other-modules: + Happy.Frontend.ParseMonad.Oracle + Happy.Frontend.Parser.Oracle diff --git a/packages/frontend/src/Happy/Frontend.hs b/packages/frontend/src/Happy/Frontend.hs new file mode 100644 index 00000000..7f2a0f23 --- /dev/null +++ b/packages/frontend/src/Happy/Frontend.hs @@ -0,0 +1,85 @@ +module Happy.Frontend (parseYFileContents, mangleAbsSyn, runFrontend, ParseResult, FrontendArgs(..), supportsParsingAttributeGrammars) where + +import Happy.Grammar.Grammar +import Happy.Frontend.AbsSyn +import Happy.Frontend.Mangler +import Happy.Frontend.PrettyGrammar +import Happy.Frontend.Parser +import Happy.Frontend.ParseMonad.Class +import System.Exit +import System.IO +import Control.Monad.Except +import Control.Monad.Trans.Except + +-------- Pure frontend functions, may be called without creating FrontendArgs -------- + +parseYFileContents :: String -> ParseResult AbsSyn +parseYFileContents contents = runFromStartP ourParser contents 1 + +mangleAbsSyn :: AbsSyn -> String -> ParseResult Grammar +mangleAbsSyn abssyn filename = first' unlines (mangler filename abssyn) + where first' f (Left a) = Left (f a) + first' _ (Right b) = Right b + +-------- Main entry point (runFrontend) -------- + +data FrontendArgs = FrontendArgs { + file :: String, + prettyFile :: Maybe String, + dumpMangle :: Bool +} + +runFrontend :: FrontendArgs -> IO (Either String Grammar) +runFrontend args = runExceptT $ do + _contents <- liftIO $ readFile file' + (contents, name) <- liftIO $ possDelitify (reverse file') _contents + abssyn <- except (parseYFileContents contents) + liftIO $ writePrettyFile prettyFile' abssyn + grammar <- except (mangleAbsSyn abssyn name) + liftIO $ optPrint dumpMangle' (print grammar) + return grammar + where + FrontendArgs { file = file', prettyFile = prettyFile', dumpMangle = dumpMangle' } = args + optPrint b io = when b (putStr "\n---------------------\n" >> io) + +-------- Helpers -------- + +writePrettyFile :: Maybe String -> AbsSyn -> IO () +writePrettyFile location abssyn = do + let out = render (ppAbsSyn abssyn) in + case location of + Just s -> writeFile s out >> + hPutStrLn stderr ("Production rules written to: " ++ s) + Nothing -> return () + +possDelitify :: String -> String -> IO (String, String) +possDelitify ('y':'l':'.':nm) fl = return (deLitify fl, reverse nm) +possDelitify ('y':'.':nm) fl = return (fl, reverse nm) +possDelitify f _ = die ("`" ++ reverse f ++ "' does not end in `.y' or `.ly'\n") +#if !MIN_VERSION_base(4,8,0) + where die s = hPutStr stderr s >> exitWith (ExitFailure 1) +#endif + +deLitify :: String -> String +deLitify = deLit where + deLit ('>':' ':r) = deLit1 r + deLit ('>':'\t':r) = '\t' : deLit1 r + deLit ('>':'\n':r) = deLit r + deLit ('>':_) = error "Error when de-litify-ing" + deLit ('\n':r) = '\n' : deLit r + deLit r = deLit2 r + deLit1 ('\n':r) = '\n' : deLit r + deLit1 (c:r) = c : deLit1 r + deLit1 [] = [] + deLit2 ('\n':r) = '\n' : deLit r + deLit2 (_:r) = deLit2 r + deLit2 [] = [] + +-------- Iff happy is built with bootstrapping, attribute grammars are supported -------- + +supportsParsingAttributeGrammars :: Bool +#ifdef HAPPY_BOOTSTRAP +supportsParsingAttributeGrammars = True +#else +supportsParsingAttributeGrammars = False +#endif \ No newline at end of file diff --git a/src/AbsSyn.lhs b/packages/frontend/src/Happy/Frontend/AbsSyn.lhs similarity index 97% rename from src/AbsSyn.lhs rename to packages/frontend/src/Happy/Frontend/AbsSyn.lhs index 6f8bbb0d..5d052571 100644 --- a/src/AbsSyn.lhs +++ b/packages/frontend/src/Happy/Frontend/AbsSyn.lhs @@ -6,8 +6,8 @@ Abstract syntax for grammar files. Here is the abstract syntax of the language we parse. -> module AbsSyn ( -> AbsSyn(..), Directive(..), ErrorHandlerType(..), +> module Happy.Frontend.AbsSyn ( +> AbsSyn(..), Directive(..), > getTokenType, getTokenSpec, getParserNames, getLexer, > getImportedIdentity, getMonad, getError, > getPrios, getPrioNames, getExpect, getErrorHandlerType, @@ -15,6 +15,8 @@ Here is the abstract syntax of the language we parse. > Rule(..), Prod(..), Term(..), Prec(..) > ) where +> import Happy.Grammar.Grammar (ErrorHandlerType(..)) + > data AbsSyn > = AbsSyn > (Maybe String) -- header @@ -45,23 +47,14 @@ Here is the abstract syntax of the language we parse. > = PrecNone -- no user-specified precedence > | PrecShift -- %shift > | PrecId String -- %prec ID - - -#ifdef DEBUG - > deriving Show -#endif - %----------------------------------------------------------------------------- Parser Generator Directives. ToDo: find a consistent way to analyse all the directives together and generate some error messages. -> data ErrorHandlerType -> = ErrorHandlerTypeDefault -> | ErrorHandlerTypeExpList > > data Directive a > = TokenType String -- %tokentype diff --git a/src/AttrGrammar.lhs b/packages/frontend/src/Happy/Frontend/AttrGrammar.lhs similarity index 97% rename from src/AttrGrammar.lhs rename to packages/frontend/src/Happy/Frontend/AttrGrammar.lhs index cf3513d6..f1d85712 100644 --- a/src/AttrGrammar.lhs +++ b/packages/frontend/src/Happy/Frontend/AttrGrammar.lhs @@ -1,4 +1,4 @@ -> module AttrGrammar +> module Happy.Frontend.AttrGrammar > ( AgToken (..) > , AgRule (..) > , HasLexer (..) @@ -8,8 +8,8 @@ > , rightRefVal > ) where +> import Happy.Frontend.ParseMonad.Class > import Data.Char -> import ParseMonad.Class > data AgToken > = AgTok_LBrace diff --git a/src/AttrGrammarParser.ly b/packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.ly similarity index 92% rename from src/AttrGrammarParser.ly rename to packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.ly index a00df123..165018cc 100644 --- a/src/AttrGrammarParser.ly +++ b/packages/frontend/src/Happy/Frontend/AttrGrammar/Parser.ly @@ -6,10 +6,10 @@ or a conditional statement. > { > {-# OPTIONS_GHC -w #-} -> module AttrGrammarParser (agParser) where -> import ParseMonad.Class -> import ParseMonad.Bootstrapped -> import AttrGrammar +> module Happy.Frontend.AttrGrammar.Parser (agParser) where +> import Happy.Frontend.ParseMonad.Class +> import Happy.Frontend.ParseMonad.Bootstrapped +> import Happy.Frontend.AttrGrammar > } > %name agParser diff --git a/packages/frontend/src/Happy/Frontend/CLI.hs b/packages/frontend/src/Happy/Frontend/CLI.hs new file mode 100644 index 00000000..23aa23af --- /dev/null +++ b/packages/frontend/src/Happy/Frontend/CLI.hs @@ -0,0 +1,60 @@ +module Happy.Frontend.CLI(Flag(..), options, parseFlags, parseAndRun, getBaseName) where + +import Happy.CLI.Dying +import Happy.Frontend +import Happy.Grammar.Grammar +import System.Console.GetOpt +import Control.Monad +import Data.List + +-------- CLI flags and options -------- + +data Flag = + OptPrettyFile (Maybe String) | + DumpMangle + deriving Eq + +options :: [OptDescr Flag] +options = [ + Option "p" ["pretty"] (OptArg OptPrettyFile "FILE") "pretty print the production rules to FILE" + +#ifdef DEBUG + , Option "" ["mangle"] (NoArg DumpMangle) "Dump mangled input" +#endif + + ] + +-------- [Flag] to FrontendArgs conversion -------- + +parseAndRun :: [Flag] -> String -> String -> IO (Either String Grammar) +parseAndRun flags filename basename = (parseFlags flags filename basename) >>= runFrontend + +parseFlags :: [Flag] -> String -> String -> IO FrontendArgs +parseFlags flags filename baseName = do + unless (filenameIsValid filename) $ dieHappy ("`" ++ filename ++ "' does not end in `.y' or `.ly'\n") + prettyName <- getPrettyFileName baseName flags + return FrontendArgs { + file = filename, + prettyFile = prettyName, + dumpMangle = DumpMangle `elem` flags + } + +filenameIsValid :: String -> Bool +filenameIsValid filename = isSuffixOf ".y" filename || isSuffixOf ".ly" filename + +getPrettyFileName :: String -> [Flag] -> IO (Maybe String) +getPrettyFileName baseName cli = case [ s | (OptPrettyFile s) <- cli ] of + [] -> return Nothing + [f] -> case f of + Nothing -> return (Just (baseName ++ ".grammar")) + Just j -> return (Just j) + _many -> dieHappy "multiple --pretty/-p options\n" + +-------- Exported helpers -------- + +-- Get filename without extension – exit if extension is neither .y nor .ly +getBaseName :: String -> IO String +getBaseName = getBaseName' . reverse where + getBaseName' ('y':'l':'.':nm) = return (reverse nm) + getBaseName' ('y':'.':nm) = return (reverse nm) + getBaseName' f = dieHappy ("`" ++ reverse f ++ "' does not end in `.y' or `.ly'\n") \ No newline at end of file diff --git a/src/Lexer.lhs b/packages/frontend/src/Happy/Frontend/Lexer.lhs similarity index 98% rename from src/Lexer.lhs rename to packages/frontend/src/Happy/Frontend/Lexer.lhs index 1e41df43..8bfe65bd 100644 --- a/src/Lexer.lhs +++ b/packages/frontend/src/Happy/Frontend/Lexer.lhs @@ -4,12 +4,12 @@ The lexer. (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- -> module Lexer ( +> module Happy.Frontend.Lexer ( > Token(..), > TokenId(..), > HasLexer(..) ) where -> import ParseMonad.Class +> import Happy.Frontend.ParseMonad.Class > import Data.Char ( isSpace, isAlphaNum, isDigit, digitToInt ) @@ -60,15 +60,7 @@ The lexer. > | TokParenL -- ( > | TokParenR -- ) > | TokComma -- , -> deriving (Eq,Ord - -#ifdef DEBUG - -> ,Show - -#endif - -> ) +> deriving (Eq,Ord,Show) ToDo: proper text instance here, for use in parser error messages. diff --git a/src/Grammar.lhs b/packages/frontend/src/Happy/Frontend/Mangler.lhs similarity index 75% rename from src/Grammar.lhs rename to packages/frontend/src/Happy/Frontend/Mangler.lhs index 6093af44..50ba0d0e 100644 --- a/src/Grammar.lhs +++ b/packages/frontend/src/Happy/Frontend/Mangler.lhs @@ -4,171 +4,34 @@ The Grammar data type. (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- -Here is our mid-section datatype +Mangler converts AbsSyn to Grammar -> module Grammar ( -> Name, -> -> Production(..), Grammar(..), mangler, ErrorHandlerType(..), -> -> LRAction(..), ActionTable, Goto(..), GotoTable, Priority(..), -> Assoc(..), -> -> errorName, errorTok, startName, firstStartTok, dummyTok, -> eofName, epsilonTok -> ) where +> module Happy.Frontend.Mangler (mangler) where -> import GenUtils -> import AbsSyn +> import Happy.Grammar.Grammar +> import Happy.Frontend.AbsSyn #ifdef HAPPY_BOOTSTRAP -> import ParseMonad.Class -> import AttrGrammar +> import Happy.Frontend.ParseMonad.Class +> import Happy.Frontend.AttrGrammar #endif This is only supported in the bootstrapped version #ifdef HAPPY_BOOTSTRAP -> import AttrGrammarParser +> import Happy.Frontend.AttrGrammar.Parser +> import Data.List ( findIndices, groupBy, intersperse, nub ) +> import Control.Monad ( when ) #endif -> import ParamRules +> import Happy.Frontend.ParamRules -> import Control.Monad ( when ) > import Data.Array ( Array, (!), accumArray, array, listArray ) > import Data.Char ( isAlphaNum, isDigit, isLower ) -> import Data.List ( findIndices, groupBy, intersperse, nub, sortBy, zip4 ) +> import Data.List ( zip4, sortBy ) > import Data.Maybe ( fromMaybe ) +> import Data.Ord ( comparing ) > import Control.Monad.Writer ( Writer, MonadWriter(..), mapWriter, runWriter ) -> type Name = Int - -> data Production -> = Production Name [Name] (String,[Int]) Priority - -#ifdef DEBUG - -> deriving Show - -#endif - -> data Grammar -> = Grammar { -> productions :: [Production], -> lookupProdNo :: Int -> Production, -> lookupProdsOfName :: Name -> [Int], -> token_specs :: [(Name,String)], -> terminals :: [Name], -> non_terminals :: [Name], -> starts :: [(String,Name,Name,Bool)], -> types :: Array Int (Maybe String), -> token_names :: Array Int String, -> first_nonterm :: Name, -> first_term :: Name, -> eof_term :: Name, -> priorities :: [(Name,Priority)], -> token_type :: String, -> imported_identity :: Bool, -> monad :: (Bool,String,String,String,String), -> expect :: Maybe Int, -> attributes :: [(String,String)], -> attributetype :: String, -> lexer :: Maybe (String,String), -> error_handler :: Maybe String, -> error_sig :: ErrorHandlerType -> } - -#ifdef DEBUG - -> instance Show Grammar where -> showsPrec _ (Grammar -> { productions = p -> , token_specs = t -> , terminals = ts -> , non_terminals = nts -> , starts = sts -> , types = tys -> , token_names = e -> , first_nonterm = fnt -> , first_term = ft -> , eof_term = eof -> }) -> = showString "productions = " . shows p -> . showString "\ntoken_specs = " . shows t -> . showString "\nterminals = " . shows ts -> . showString "\nnonterminals = " . shows nts -> . showString "\nstarts = " . shows sts -> . showString "\ntypes = " . shows tys -> . showString "\ntoken_names = " . shows e -> . showString "\nfirst_nonterm = " . shows fnt -> . showString "\nfirst_term = " . shows ft -> . showString "\neof = " . shows eof -> . showString "\n" - -#endif - -> data Assoc = LeftAssoc | RightAssoc | None - -#ifdef DEBUG - -> deriving Show - -#endif - -> data Priority = No | Prio Assoc Int | PrioLowest - -#ifdef DEBUG - -> deriving Show - -#endif - -> instance Eq Priority where -> No == No = True -> Prio _ i == Prio _ j = i == j -> _ == _ = False - -> mkPrio :: Int -> Directive a -> Priority -> mkPrio i (TokenNonassoc _) = Prio None i -> mkPrio i (TokenRight _) = Prio RightAssoc i -> mkPrio i (TokenLeft _) = Prio LeftAssoc i -> mkPrio _ _ = error "Panic: impossible case in mkPrio" - ------------------------------------------------------------------------------ --- Magic name values - -All the tokens in the grammar are mapped onto integers, for speed. -The namespace is broken up as follows: - -epsilon = 0 -error = 1 -dummy = 2 -%start = 3..s -non-terminals = s..n -terminals = n..m -%eof = m - -These numbers are deeply magical, change at your own risk. Several -other places rely on these being arranged as they are, including -ProduceCode.lhs and the various HappyTemplates. - -Unfortunately this means you can't tell whether a given token is a -terminal or non-terminal without knowing the boundaries of the -namespace, which are kept in the Grammar structure. - -In hindsight, this was probably a bad idea. - -> startName, eofName, errorName, dummyName :: String -> startName = "%start" -- with a suffix, like %start_1, %start_2 etc. -> eofName = "%eof" -> errorName = "error" -> dummyName = "%dummy" -- shouldn't occur in the grammar anywhere - -> firstStartTok, dummyTok, errorTok, epsilonTok :: Name -> firstStartTok = 3 -> dummyTok = 2 -> errorTok = 1 -> epsilonTok = 0 - ----------------------------------------------------------------------------- -- The Mangler @@ -258,15 +121,21 @@ Deal with priorities... > priodir = zip [1..] (getPrios dirs) > +> mkPrio :: Int -> Directive a -> Priority +> mkPrio i (TokenNonassoc _) = Prio None i +> mkPrio i (TokenRight _) = Prio RightAssoc i +> mkPrio i (TokenLeft _) = Prio LeftAssoc i +> mkPrio _ _ = error "Panic: impossible case in mkPrio" + > prios = [ (name,mkPrio i dir) > | (i,dir) <- priodir -> , nm <- AbsSyn.getPrioNames dir +> , nm <- getPrioNames dir > , name <- lookupName nm > ] > prioByString = [ (name, mkPrio i dir) > | (i,dir) <- priodir -> , name <- AbsSyn.getPrioNames dir +> , name <- getPrioNames dir > ] Translate the rules from string to name-based. @@ -389,9 +258,22 @@ Get the token specs in terms of Names. > token_type = getTokenType dirs, > expect = getExpect dirs, > attributes = attrs, -> attributetype = attrType +> attributetype = attrType, +> hd = _hd, +> tl = _tl > }) +Gofer-like stuff. + +> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])] +> combinePairs xs = +> combine [ (a,[b]) | (a,b) <- sortBy (comparing fst) xs] +> where +> combine [] = [] +> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r) +> combine (a:r) = a : combine r +> + For combining actions with possible error messages. > addLine :: Int -> String -> String @@ -413,7 +295,6 @@ So is this. > checkRules [] _ nonterms = return (reverse nonterms) - ----------------------------------------------------------------------------- -- If any attribute directives were used, we are in an attribute grammar, so -- go do special processing. If not, pass on to the regular processing routine @@ -597,46 +478,4 @@ So is this. > c:r -> go r (c:acc) used > mkHappyVar :: Int -> String -> mkHappyVar n = "happy_var_" ++ show n - ------------------------------------------------------------------------------ --- Internal Reduction Datatypes - -> data LRAction = LR'Shift Int Priority -- state number and priority -> | LR'Reduce Int Priority-- rule no and priority -> | LR'Accept -- :-) -> | LR'Fail -- :-( -> | LR'MustFail -- :-( -> | LR'Multiple [LRAction] LRAction -- conflict -> deriving(Eq - -#ifdef DEBUG - -> ,Show - -#endif - -> ) - -> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction) - - instance Text LRAction where - showsPrec _ (LR'Shift i _) = showString ("s" ++ show i) - showsPrec _ (LR'Reduce i _) - = showString ("r" ++ show i) - showsPrec _ (LR'Accept) = showString ("acc") - showsPrec _ (LR'Fail) = showString (" ") - instance Eq LRAction where { (==) = primGenericEq } - -> data Goto = Goto Int | NoGoto -> deriving(Eq - -#ifdef DEBUG - -> ,Show - -#endif - -> ) - -> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto) +> mkHappyVar n = "happy_var_" ++ show n \ No newline at end of file diff --git a/src/ParamRules.hs b/packages/frontend/src/Happy/Frontend/ParamRules.hs similarity index 97% rename from src/ParamRules.hs rename to packages/frontend/src/Happy/Frontend/ParamRules.hs index 0f285aa7..20d55a90 100644 --- a/src/ParamRules.hs +++ b/packages/frontend/src/Happy/Frontend/ParamRules.hs @@ -1,6 +1,6 @@ -module ParamRules(expand_rules, Prod1(..), Rule1(..)) where +module Happy.Frontend.ParamRules(expand_rules, Prod1(..), Rule1(..)) where -import AbsSyn +import Happy.Frontend.AbsSyn import Control.Monad.Writer import Control.Monad.Except import Data.List(partition,intersperse) diff --git a/packages/frontend/src/Happy/Frontend/ParseMonad.hs b/packages/frontend/src/Happy/Frontend/ParseMonad.hs new file mode 100644 index 00000000..9c28cdea --- /dev/null +++ b/packages/frontend/src/Happy/Frontend/ParseMonad.hs @@ -0,0 +1,8 @@ +module Happy.Frontend.ParseMonad (module X) where + +-- We use the bootstrapped version if it is available +#ifdef HAPPY_BOOTSTRAP +import Happy.Frontend.ParseMonad.Bootstrapped as X +#else +import Happy.Frontend.ParseMonad.Oracle as X +#endif diff --git a/src/ParseMonad/Bootstrapped.hs b/packages/frontend/src/Happy/Frontend/ParseMonad/Bootstrapped.hs similarity index 88% rename from src/ParseMonad/Bootstrapped.hs rename to packages/frontend/src/Happy/Frontend/ParseMonad/Bootstrapped.hs index 50fee187..6e54f13c 100644 --- a/src/ParseMonad/Bootstrapped.hs +++ b/packages/frontend/src/Happy/Frontend/ParseMonad/Bootstrapped.hs @@ -8,10 +8,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} #endif -module ParseMonad.Bootstrapped where +module Happy.Frontend.ParseMonad.Bootstrapped where +import Happy.Frontend.ParseMonad.Class import Control.Monad.Reader -import ParseMonad.Class type P = ReaderT (String, Int) ParseResult diff --git a/src/ParseMonad/Class.hs b/packages/frontend/src/Happy/Frontend/ParseMonad/Class.hs similarity index 86% rename from src/ParseMonad/Class.hs rename to packages/frontend/src/Happy/Frontend/ParseMonad/Class.hs index 6824d768..bb967bb2 100644 --- a/src/ParseMonad/Class.hs +++ b/packages/frontend/src/Happy/Frontend/ParseMonad/Class.hs @@ -1,4 +1,4 @@ -module ParseMonad.Class where +module Happy.Frontend.ParseMonad.Class where type Pfunc a = String -> Int -> ParseResult a diff --git a/src/ParseMonad/Oracle.hs b/packages/frontend/src/Happy/Frontend/ParseMonad/Oracle.hs similarity index 96% rename from src/ParseMonad/Oracle.hs rename to packages/frontend/src/Happy/Frontend/ParseMonad/Oracle.hs index 1e770db3..a52d0d7d 100644 --- a/src/ParseMonad/Oracle.hs +++ b/packages/frontend/src/Happy/Frontend/ParseMonad/Oracle.hs @@ -1,13 +1,13 @@ {-# LANGUAGE RankNTypes #-} -module ParseMonad.Oracle where +module Happy.Frontend.ParseMonad.Oracle where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Monad -import ParseMonad.Class +import Happy.Frontend.ParseMonad.Class data PState token = PS !String diff --git a/packages/frontend/src/Happy/Frontend/Parser.hs b/packages/frontend/src/Happy/Frontend/Parser.hs new file mode 100644 index 00000000..0c07cb56 --- /dev/null +++ b/packages/frontend/src/Happy/Frontend/Parser.hs @@ -0,0 +1,8 @@ +module Happy.Frontend.Parser (module X) where + +-- We use the bootstrapped version if it is available +#ifdef HAPPY_BOOTSTRAP +import Happy.Frontend.Parser.Bootstrapped as X +#else +import Happy.Frontend.Parser.Oracle as X +#endif diff --git a/src/Parser/Bootstrapped.ly b/packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly similarity index 96% rename from src/Parser/Bootstrapped.ly rename to packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly index 4ba44ff1..e84a330c 100644 --- a/src/Parser/Bootstrapped.ly +++ b/packages/frontend/src/Happy/Frontend/Parser/Bootstrapped.ly @@ -8,11 +8,11 @@ The parser. > { > {-# OPTIONS_GHC -w #-} -> module Parser.Bootstrapped (ourParser,AbsSyn) where -> import ParseMonad.Class -> import ParseMonad.Bootstrapped -> import AbsSyn -> import Lexer +> module Happy.Frontend.Parser.Bootstrapped (ourParser,AbsSyn) where +> import Happy.Frontend.ParseMonad.Class +> import Happy.Frontend.ParseMonad.Bootstrapped +> import Happy.Frontend.AbsSyn +> import Happy.Frontend.Lexer > } > %name ourParser diff --git a/src/Parser/Oracle.hs b/packages/frontend/src/Happy/Frontend/Parser/Oracle.hs similarity index 97% rename from src/Parser/Oracle.hs rename to packages/frontend/src/Happy/Frontend/Parser/Oracle.hs index 7f7273c5..5e573cd6 100644 --- a/src/Parser/Oracle.hs +++ b/packages/frontend/src/Happy/Frontend/Parser/Oracle.hs @@ -1,17 +1,17 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} -module Parser.Oracle (ourParser, AbsSyn) where +module Happy.Frontend.Parser.Oracle (ourParser, AbsSyn) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif +import Happy.Frontend.ParseMonad.Class +import Happy.Frontend.ParseMonad.Oracle +import Happy.Frontend.AbsSyn +import Happy.Frontend.Lexer import Control.Monad (when) import Data.Maybe (isJust) -import ParseMonad.Class -import ParseMonad.Oracle -import AbsSyn -import Lexer type Parser = P Token diff --git a/src/PrettyGrammar.hs b/packages/frontend/src/Happy/Frontend/PrettyGrammar.hs similarity index 96% rename from src/PrettyGrammar.hs rename to packages/frontend/src/Happy/Frontend/PrettyGrammar.hs index f88e931f..bbcec62a 100644 --- a/src/PrettyGrammar.hs +++ b/packages/frontend/src/Happy/Frontend/PrettyGrammar.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} -module PrettyGrammar where +module Happy.Frontend.PrettyGrammar where #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif -import AbsSyn +import Happy.Frontend.AbsSyn render :: Doc -> String render = maybe "" ($ "") diff --git a/packages/grammar/LICENSE b/packages/grammar/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/grammar/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/packages/grammar/Setup.hs b/packages/grammar/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/grammar/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/packages/grammar/happy-grammar.cabal b/packages/grammar/happy-grammar.cabal new file mode 100644 index 00000000..fb8fc19f --- /dev/null +++ b/packages/grammar/happy-grammar.cabal @@ -0,0 +1,45 @@ +name: happy-grammar +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: happy's Grammar datatype + +Description: + Happy is a parser generator for Haskell. + Happy-Grammar exposes the cross-package Grammar datatype, + which represents a grammar as can be parsed and processed by happy. + +tested-with: + GHC == 7.0.4 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +library + hs-source-dirs: src + + exposed-modules: Happy.Grammar.Grammar + build-depends: base < 5, + array + + default-language: Haskell98 + default-extensions: CPP, MagicHash, FlexibleContexts + ghc-options: -Wall + other-modules: diff --git a/packages/grammar/src/Happy/Grammar/Grammar.lhs b/packages/grammar/src/Happy/Grammar/Grammar.lhs new file mode 100644 index 00000000..0c5df2f7 --- /dev/null +++ b/packages/grammar/src/Happy/Grammar/Grammar.lhs @@ -0,0 +1,152 @@ +/----------------------------------------------------------------------------- +The Grammar data type. + +(c) 1993-2001 Andy Gill, Simon Marlow +----------------------------------------------------------------------------- + +> module Happy.Grammar.Grammar ( +> Name, +> +> Production(..), Grammar(..), ErrorHandlerType(..), +> Priority(..), +> Assoc(..), +> +> errorName, errorTok, startName, dummyName, firstStartTok, dummyTok, +> eofName, epsilonTok, +> +> mapDollarDollar +> ) where + +> import Data.Array +> import Data.Char (isAlphaNum) + +> type Name = Int + +> data ErrorHandlerType +> = ErrorHandlerTypeDefault +> | ErrorHandlerTypeExpList + +> data Production +> = Production Name [Name] (String,[Int]) Priority +> deriving (Show) + +> data Grammar +> = Grammar { +> productions :: [Production], +> lookupProdNo :: Int -> Production, +> lookupProdsOfName :: Name -> [Int], +> token_specs :: [(Name,String)], +> terminals :: [Name], +> non_terminals :: [Name], +> starts :: [(String,Name,Name,Bool)], +> types :: Array Int (Maybe String), +> token_names :: Array Int String, +> first_nonterm :: Name, +> first_term :: Name, +> eof_term :: Name, +> priorities :: [(Name,Priority)], +> token_type :: String, +> imported_identity :: Bool, +> monad :: (Bool,String,String,String,String), +> expect :: Maybe Int, +> attributes :: [(String,String)], +> attributetype :: String, +> lexer :: Maybe (String,String), +> error_handler :: Maybe String, +> error_sig :: ErrorHandlerType, +> hd :: Maybe String, +> tl :: Maybe String +> } + +> instance Show Grammar where +> showsPrec _ (Grammar +> { productions = p +> , token_specs = t +> , terminals = ts +> , non_terminals = nts +> , starts = sts +> , types = tys +> , token_names = e +> , first_nonterm = fnt +> , first_term = ft +> , eof_term = eof +> }) +> = showString "productions = " . shows p +> . showString "\ntoken_specs = " . shows t +> . showString "\nterminals = " . shows ts +> . showString "\nnonterminals = " . shows nts +> . showString "\nstarts = " . shows sts +> . showString "\ntypes = " . shows tys +> . showString "\ntoken_names = " . shows e +> . showString "\nfirst_nonterm = " . shows fnt +> . showString "\nfirst_term = " . shows ft +> . showString "\neof = " . shows eof +> . showString "\n" + +> data Assoc = LeftAssoc | RightAssoc | None +> deriving Show + +> data Priority = No | Prio Assoc Int | PrioLowest +> deriving Show + +> instance Eq Priority where +> No == No = True +> Prio _ i == Prio _ j = i == j +> _ == _ = False + +----------------------------------------------------------------------------- +-- Magic name values + +All the tokens in the grammar are mapped onto integers, for speed. +The namespace is broken up as follows: + +epsilon = 0 +error = 1 +dummy = 2 +%start = 3..s +non-terminals = s..n +terminals = n..m +%eof = m + +These numbers are deeply magical, change at your own risk. Several +other places rely on these being arranged as they are, including +ProduceCode.lhs and the various HappyTemplates. + +Unfortunately this means you can't tell whether a given token is a +terminal or non-terminal without knowing the boundaries of the +namespace, which are kept in the Grammar structure. + +In hindsight, this was probably a bad idea. + +> startName, eofName, errorName, dummyName :: String +> startName = "%start" -- with a suffix, like %start_1, %start_2 etc. +> eofName = "%eof" +> errorName = "error" +> dummyName = "%dummy" -- shouldn't occur in the grammar anywhere + +> firstStartTok, dummyTok, errorTok, epsilonTok :: Name +> firstStartTok = 3 +> dummyTok = 2 +> errorTok = 1 +> epsilonTok = 0 + +----------------------------------------------------------------------------- + +Replace $$ with an arbitrary string, being careful to avoid ".." and '.'. + +> mapDollarDollar :: String -> Maybe (String -> String) +> mapDollarDollar code0 = go code0 "" +> where go code acc = +> case code of +> [] -> Nothing +> +> '"' :r -> case reads code :: [(String,String)] of +> [] -> go r ('"':acc) +> (s,r'):_ -> go r' (reverse (show s) ++ acc) +> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc) +> '\'' :r -> case reads code :: [(Char,String)] of +> [] -> go r ('\'':acc) +> (c,r'):_ -> go r' (reverse (show c) ++ acc) +> '\\':'$':r -> go r ('$':acc) +> '$':'$':r -> Just (\repl -> reverse acc ++ repl ++ r) +> c:r -> go r (c:acc) \ No newline at end of file diff --git a/packages/happy/ChangeLog.md b/packages/happy/ChangeLog.md new file mode 120000 index 00000000..90085551 --- /dev/null +++ b/packages/happy/ChangeLog.md @@ -0,0 +1 @@ +../../ChangeLog.md \ No newline at end of file diff --git a/packages/happy/LICENSE b/packages/happy/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/happy/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/packages/happy/README.md b/packages/happy/README.md new file mode 120000 index 00000000..fe840054 --- /dev/null +++ b/packages/happy/README.md @@ -0,0 +1 @@ +../../README.md \ No newline at end of file diff --git a/packages/happy/Setup.hs b/packages/happy/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/happy/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/packages/happy/TODO b/packages/happy/TODO new file mode 120000 index 00000000..16594029 --- /dev/null +++ b/packages/happy/TODO @@ -0,0 +1 @@ +../../TODO \ No newline at end of file diff --git a/packages/happy/doc b/packages/happy/doc new file mode 120000 index 00000000..7e57b0f5 --- /dev/null +++ b/packages/happy/doc @@ -0,0 +1 @@ +../../doc \ No newline at end of file diff --git a/packages/happy/examples b/packages/happy/examples new file mode 120000 index 00000000..d15735c1 --- /dev/null +++ b/packages/happy/examples @@ -0,0 +1 @@ +../../examples \ No newline at end of file diff --git a/happy.cabal b/packages/happy/happy.cabal similarity index 60% rename from happy.cabal rename to packages/happy/happy.cabal index f33e53cd..da04d8b2 100644 --- a/happy.cabal +++ b/packages/happy/happy.cabal @@ -1,17 +1,17 @@ -name: happy -version: 1.20.0.20210714 -license: BSD2 -license-file: LICENSE -copyright: (c) Andy Gill, Simon Marlow -author: Andy Gill and Simon Marlow -maintainer: Simon Marlow -bug-reports: https://github.com/simonmar/happy/issues -stability: stable -homepage: https://www.haskell.org/happy/ -synopsis: Happy is a parser generator for Haskell -category: Development -cabal-version: >= 1.10 -build-type: Simple +name: happy +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: Happy is a parser generator for Haskell Description: Happy is a parser generator for Haskell. Given a grammar @@ -32,16 +32,8 @@ tested-with: GHC == 8.10.4 GHC == 9.0.1 -data-dir: data/ - -data-files: - HappyTemplate.hs - GLR_Base.hs - GLR_Lib.hs - extra-source-files: ChangeLog.md - Makefile README.md TODO doc/Makefile @@ -113,41 +105,6 @@ extra-source-files: examples/ErlParser.ly examples/SimonsExample.ly examples/LexerTest.ly - src/ARRAY-NOTES - tests/AttrGrammar001.y - tests/AttrGrammar002.y - tests/Makefile - tests/Partial.ly - tests/Test.ly - tests/TestMulti.ly - tests/TestPrecedence.ly - tests/bogus-token.y - tests/bug001.ly - tests/bug002.y - tests/error001.stderr - tests/error001.stdout - tests/error001.y - tests/monad001.y - tests/monad002.ly - tests/monaderror.y - tests/precedence001.ly - tests/precedence002.y - tests/test_rules.y - tests/issue91.y - tests/issue93.y - tests/issue94.y - tests/issue95.y - tests/monaderror-explist.y - tests/typeclass_monad001.y - tests/typeclass_monad002.ly - tests/typeclass_monad_lexer.y - tests/rank2.y - tests/shift01.y - -flag bootstrap - description: Optimize the implementation of happy using a pre-built happy - manual: True - default: True source-repository head type: git @@ -155,58 +112,34 @@ source-repository head executable happy hs-source-dirs: src - main-is: Main.lhs + main-is: Main.hs build-depends: base < 5, array, containers >= 0.4.2, - mtl >= 2.2.1 - -- mtl-2.2.1 added Control.Monad.Except + mtl >= 2.2.1, + transformers >= 0.5, + happy-grammar == 1.21.0, + happy-cli == 1.21.0, + happy-frontend == 1.21.0, + happy-tabular == 1.21.0, + happy-backend == 1.21.0, + happy-backend-glr == 1.21.0 default-language: Haskell98 default-extensions: CPP, MagicHash, FlexibleContexts ghc-options: -Wall other-modules: Paths_happy - AbsSyn - First - GenUtils - Grammar - Info - LALR - Lexer - ParseMonad - ParseMonad.Class - Parser - ProduceCode - ProduceGLRCode - NameSet - Target - AttrGrammar - ParamRules - PrettyGrammar - - if flag(bootstrap) - -- TODO put this back when Cabal can use it's qualified goals to better - -- understand bootstrapping, see - -- https://github.com/haskell/cabal/issues/7189 - --build-tools: happy - cpp-options: -DHAPPY_BOOTSTRAP - other-modules: - ParseMonad.Bootstrapped - Parser.Bootstrapped - AttrGrammarParser - else - other-modules: - ParseMonad.Oracle - Parser.Oracle - -test-suite tests +test-suite test type: exitcode-stdio-1.0 - main-is: test.hs - -- This line is important as it ensures that the local `exe:happy` component declared above is built before the test-suite component is invoked, as well as making sure that `happy` is made available on $PATH and `$happy_datadir` is set accordingly before invoking `test.hs` + main-is: tests.hs + -- This line is important as it ensures that the local `exe:happy` component declared above is built before the test-suite component is invoked, as well as making sure that `happy` is made available on $PATH and `$happy_datadir` is set accordingly before invoking `tests.hs` build-tools: happy - build-depends: base, process + ghc-options: -threaded + build-depends: base, happy-test, happy-frontend default-language: Haskell98 + other-modules: + Paths_happy diff --git a/packages/happy/src/Main.hs b/packages/happy/src/Main.hs new file mode 100644 index 00000000..bfcb20cc --- /dev/null +++ b/packages/happy/src/Main.hs @@ -0,0 +1,83 @@ +module Main where + +import qualified Happy.Frontend.CLI as FrontendCLI +import qualified Happy.Tabular.CLI as TabularCLI +import qualified Happy.Backend.CLI as BackendCLI +import qualified Happy.Backend.GLR.CLI as GLRBackendCLI +import qualified Happy.Backend as Backend +import qualified Happy.Backend.GLR as GLRBackend +import Happy.CLI.Dying +import Happy.CLI.OptionParsing +import Control.Monad.Except +import System.Console.GetOpt +import System.Environment +import Paths_happy (version) + +-- Option for switching between backend and glr-backend +useGLROption :: OptDescr TopLevelFlag +useGLROption = Option "l" ["glr"] (NoArg OptGLR) "Generate a GLR parser for ambiguous grammars" +data TopLevelFlag = OptGLR deriving Eq + +-- Combine the flags from all the packages +data HappyFlag = TopLevel TopLevelFlag | Frontend FrontendCLI.Flag | Tabular TabularCLI.Flag | Backend BackendCLI.Flag | GLRBackend GLRBackendCLI.Flag deriving Eq + +as :: Functor f => [f a] -> (a -> b) -> [f b] +a `as` b = map (fmap b) a + +getTopLevel :: [HappyFlag] -> [TopLevelFlag] +getFrontend :: [HappyFlag] -> [FrontendCLI.Flag] +getTabular :: [HappyFlag] -> [TabularCLI.Flag] +getBackend :: [HappyFlag] -> [BackendCLI.Flag] +getGLRBackend :: [HappyFlag] -> [GLRBackendCLI.Flag] +getTopLevel flags = [a | TopLevel a <- flags] +getFrontend flags = [a | Frontend a <- flags] +getTabular flags = [a | Tabular a <- flags] +getBackend flags = [a | Backend a <- flags] +getGLRBackend flags = [a | GLRBackend a <- flags] + +-- Stick options togehter from all packages +allOptions :: [OptDescr HappyFlag] +allOptions = + FrontendCLI.options `as` Frontend ++ + TabularCLI.options `as` Tabular ++ + BackendCLI.options `as` Backend ++ + -- Add the "--glr" option. Remove options that are already declared in happy-backend like outfile, template, ghc, debug. + [useGLROption] `as` TopLevel ++ + removeAllOverlaps BackendCLI.options GLRBackendCLI.options `as` GLRBackend + +-- Main +main :: IO () +main = do + let sortedOpts = beginOptionsWith "oip" allOptions -- Order: outfile, info, pretty + (flags, freeOpts) <- parseOptions sortedOpts version =<< getArgs + filename <- requireUnnamedArgument freeOpts sortedOpts DieUsage0 DieUsageMult + basename <- FrontendCLI.getBaseName filename + + grammar <- try $ FrontendCLI.parseAndRun (getFrontend flags) filename basename + (action, goto, _, _) <- TabularCLI.parseAndRun (getTabular flags) filename basename grammar + + -- Backend / GLRBackend switching + let useGLR = OptGLR `elem` getTopLevel flags + backendOpts <- BackendCLI.parseFlags (getBackend flags) basename + + case useGLR of + True -> GLRBackend.runGLRBackend (createGLROpts (getGLRBackend flags) backendOpts basename) grammar action goto + False -> Backend.runBackend backendOpts grammar action goto + +-- Fill those glr-options that were removed due to overlap with happy-backend's options +createGLROpts :: [GLRBackendCLI.Flag] -> Backend.BackendArgs -> String -> GLRBackend.GLRBackendArgs +createGLROpts glrFlags backendOpts basename = + let glrOpts' = GLRBackendCLI.parseFlags glrFlags basename + in glrOpts' { + GLRBackend.outFile = Backend.outFile backendOpts, + GLRBackend.templateDir = Backend.templateDir backendOpts, + GLRBackend.ghc = Backend.ghc backendOpts, + GLRBackend.debug = Backend.debug backendOpts + } + +try :: IO (Either String a) -> IO a +try f = do + result <- f + case result of + Left err -> liftIO $ die err + Right a -> return a \ No newline at end of file diff --git a/packages/happy/tests.hs b/packages/happy/tests.hs new file mode 100644 index 00000000..78438de7 --- /dev/null +++ b/packages/happy/tests.hs @@ -0,0 +1,18 @@ +import Happy.Test +import Happy.Frontend +import Paths_happy + +main = do + dir <- getDataDir + let tests = defaultTestFiles ++ + (if supportsParsingAttributeGrammars then attributeGrammarTestFiles else []) + let setup = TestSetup { + happyExec = "happy", + haskellCompilerExec = "ghc", + defaultTests = tests, + customTests = [], + customDataDir = dir, + allArguments = map ("--strict " ++) ["", "-a", "-g", "-ag", "-gc", "-agc"], + stopOnFailure = True + } + test setup diff --git a/packages/tabular/LICENSE b/packages/tabular/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/tabular/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/packages/tabular/Setup.hs b/packages/tabular/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/tabular/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/packages/tabular/happy-tabular.cabal b/packages/tabular/happy-tabular.cabal new file mode 100644 index 00000000..2decff14 --- /dev/null +++ b/packages/tabular/happy-tabular.cabal @@ -0,0 +1,59 @@ +name: happy-tabular +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: Action and goto tables for happy + +Description: + Happy is a parser generator for Haskell. + Happy-Tabular converts `Grammar`s, coming from + a frontend, into LALR action and goto tables, + which are further processed by a backend. + +tested-with: + GHC == 7.0.4 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +extra-source-files: src/Happy/Tabular/ARRAY-NOTES + +library + hs-source-dirs: src + + exposed-modules: Happy.Tabular, + Happy.Tabular.CLI, + Happy.Tabular.First, + Happy.Tabular.Tables + build-depends: base < 5, + array, + containers >= 0.4.2, + happy-cli == 1.21.0, + happy-grammar == 1.21.0 + + default-language: Haskell98 + default-extensions: CPP, MagicHash, FlexibleContexts + ghc-options: -Wall + other-modules: + Happy.Tabular.LALR, + Happy.Tabular.FindRedundancies, + Happy.Tabular.Info, + Happy.Tabular.NameSet, + Paths_happy_tabular diff --git a/packages/tabular/src/Happy/Tabular.hs b/packages/tabular/src/Happy/Tabular.hs new file mode 100644 index 00000000..92d2a5ee --- /dev/null +++ b/packages/tabular/src/Happy/Tabular.hs @@ -0,0 +1,119 @@ +module Happy.Tabular( + mkFirst, genLR0Items, genLookaheads, genLR1States, genActionTable, genGotoTable, countConflicts, + Lr0Item(..), Lr1Item(..), Lr0State, Lr1State, LookaheadInfo, + TabularArgs(..), TabularResult, runTabular + ) where + +import Happy.Grammar.Grammar +import Happy.Tabular.NameSet (NameSet) +import Happy.Tabular.Tables +import Happy.Tabular.First +import qualified Happy.Tabular.LALR as LALR +import Happy.Tabular.LALR (Lr0Item, Lr1Item, precalcClosure0, propLookaheads, calcLookaheads, mergeLookaheadInfo) +import Happy.Tabular.FindRedundancies +import Happy.Tabular.Info +import Data.Set (Set) +import Data.Array (Array) +import System.IO +import System.Exit +import Control.Monad + +-------- Pure tabular functions, may be called without creating TabularArgs -------- + +type Lr0State = (Set Lr0Item, [(Name, Int)]) +type Lr1State = ([Lr1Item], [(Name, Int)]) +type LookaheadInfo = Array Int [(Lr0Item, NameSet)] + +genLR0Items :: Grammar -> [Lr0State] +genLR0Items g = LALR.genLR0items g (precalcClosure0 g) + +genLookaheads :: Grammar -> [Lr0State] -> ([Name] -> NameSet) -> LookaheadInfo +genLookaheads g sets first = + let (spont, prop) = propLookaheads g sets first in + calcLookaheads (length sets) spont prop + +genLR1States :: LookaheadInfo -> [Lr0State] -> [Lr1State] +genLR1States = mergeLookaheadInfo + +genActionTable :: Grammar -> ([Name] -> NameSet) -> [Lr1State] -> ActionTable +genActionTable = LALR.genActionTable + +genGotoTable :: Grammar -> [Lr0State] -> GotoTable +genGotoTable = LALR.genGotoTable + +countConflicts :: ActionTable -> (Array Int (Int, Int), (Int, Int)) +countConflicts = LALR.countConflicts + +-------- Main entry point (runTabular) -------- + +data TabularArgs = TabularArgs { + inFile :: String, -- printed to the info file, not used otherwise + infoFile :: Maybe String, + + dumpLR0 :: Bool, + dumpLA :: Bool, + dumpAction :: Bool, + dumpGoto :: Bool +} + +type TabularResult = (ActionTable, GotoTable, [Lr1State], [Int]) + +runTabular :: TabularArgs -> Grammar -> IO TabularResult +runTabular args g = + let first = mkFirst g + sets = genLR0Items g + la = genLookaheads g sets first + items2 = genLR1States la sets + goto = genGotoTable g sets + action = genActionTable g first items2 + (conflictArray, (sr,rr)) = (countConflicts action) + in do + optPrint (dumpLR0 args) (print sets) + optPrint (dumpLA args) (print la) + optPrint (dumpAction args) (print action) + optPrint (dumpGoto args) (print goto) + (unused_rules, unused_terminals) <- reportUnusedRules g action + writeInfoFile sets g action goto conflictArray (inFile args) (infoFile args) unused_rules unused_terminals + reportConflicts g sr rr + return (action, goto, items2, unused_rules) + where + optPrint b io = when b (putStr "\n---------------------\n" >> io) + + +-------- Helpers -------- + +reportUnusedRules :: Grammar -> ActionTable -> IO ([Int], [String]) +reportUnusedRules g action = + let result@(unused_rules, unused_terminals) = find_redundancies first_reduction g action in do + when (not (null unused_rules)) $ hPutStrLn stderr ("unused rules: " ++ show (length unused_rules)) + when (not (null unused_terminals)) $ hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals)) + return result + +reportConflicts :: Grammar -> Int -> Int -> IO () +reportConflicts g sr rr = case expect g of + Just n | n == sr && rr == 0 -> return () + Just _ | rr > 0 -> + die $ "The grammar has reduce/reduce conflicts.\n" ++ + "This is not allowed when an expect directive is given\n" + Just _ -> + die $ "The grammar has " ++ show sr ++ " shift/reduce conflicts.\n" ++ + "This is different from the number given in the expect directive\n" + _ -> do + if sr /= 0 + then hPutStrLn stderr ("shift/reduce conflicts: " ++ show sr) + else return () + + if rr /= 0 + then hPutStrLn stderr ("reduce/reduce conflicts: " ++ show rr) + else return () +#if !MIN_VERSION_base(4,8,0) + where die s = hPutStr stderr s >> exitWith (ExitFailure 1) +#endif + +type ItemSetWithGotos = (Set Lr0Item, [(Name,Int)]) +writeInfoFile :: [ItemSetWithGotos] -> Grammar -> ActionTable -> GotoTable -> Array Int (Int,Int) -> String -> Maybe String -> [Int] -> [String] -> IO () +writeInfoFile sets g action goto conflictArray file info_file unused_rules unused_terminals = + let info = genInfoFile (map fst sets) g action goto (token_specs g) conflictArray file unused_rules unused_terminals in + case info_file of + Just s -> writeFile s info >> hPutStrLn stderr ("Grammar info written to: " ++ s) + Nothing -> return () \ No newline at end of file diff --git a/src/ARRAY-NOTES b/packages/tabular/src/Happy/Tabular/ARRAY-NOTES similarity index 100% rename from src/ARRAY-NOTES rename to packages/tabular/src/Happy/Tabular/ARRAY-NOTES diff --git a/packages/tabular/src/Happy/Tabular/CLI.hs b/packages/tabular/src/Happy/Tabular/CLI.hs new file mode 100644 index 00000000..cc8a428c --- /dev/null +++ b/packages/tabular/src/Happy/Tabular/CLI.hs @@ -0,0 +1,54 @@ +module Happy.Tabular.CLI(Flag(..), options, parseFlags, parseAndRun) where + +import Happy.CLI.Dying +import Happy.Tabular +import Happy.Grammar.Grammar +import System.Console.GetOpt + +-------- CLI flags and options -------- + +data Flag = + OptInfoFile (Maybe String) | + DumpLR0 | + DumpLA | + DumpAction | + DumpGoto + deriving Eq + +options :: [OptDescr Flag] +options = [ + Option "i" ["info"] (OptArg OptInfoFile "FILE") "put detailed grammar info in FILE" + +#ifdef DEBUG + , Option "" ["lr0"] (NoArg DumpLR0) "Dump LR0 item sets", + Option "" ["action"] (NoArg DumpAction) "Dump action table", + Option "" ["goto"] (NoArg DumpGoto) "Dump goto table", + Option "" ["lookaheads"] (NoArg DumpLA) "Dump lookahead info" +#endif + + ] + +-------- [Flag] to TabularArgs conversion -------- + +parseAndRun :: [Flag] -> String -> String -> Grammar -> IO TabularResult +parseAndRun flags filename basename grammar = (parseFlags flags filename basename) >>= flip runTabular grammar + +parseFlags :: [Flag] -> String -> String -> IO TabularArgs +parseFlags cli fileName baseName = do + infoFile' <- getInfoFileName baseName cli + return TabularArgs { + inFile = fileName, + infoFile = infoFile', + dumpLR0 = DumpLR0 `elem` cli, + dumpLA = DumpLA `elem` cli, + dumpAction = DumpAction `elem` cli, + dumpGoto = DumpGoto `elem` cli + } + +getInfoFileName :: String -> [Flag] -> IO (Maybe String) +getInfoFileName base cli = case [ s | (OptInfoFile s) <- cli ] of + [] -> return Nothing + [f] -> case f of + Nothing -> return (Just (base ++ ".info")) + Just j -> return (Just j) + _many -> dieHappy "multiple --info/-i options\n" \ No newline at end of file diff --git a/packages/tabular/src/Happy/Tabular/FindRedundancies.lhs b/packages/tabular/src/Happy/Tabular/FindRedundancies.lhs new file mode 100644 index 00000000..68e2a449 --- /dev/null +++ b/packages/tabular/src/Happy/Tabular/FindRedundancies.lhs @@ -0,0 +1,48 @@ +> module Happy.Tabular.FindRedundancies where + +> import Happy.Grammar.Grammar +> import Happy.Tabular.Tables +> import Data.Array( assocs, elems, (!) ) +> import Data.List + +Find unused rules and tokens + +> find_redundancies +> :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String]) +> find_redundancies extract_reductions g action_table = +> (unused_rules, map (env !) unused_terminals) +> where +> Grammar { terminals = terms, +> token_names = env, +> eof_term = eof, +> starts = starts', +> productions = productions' +> } = g + +> actions = concat (map assocs (elems action_table)) +> start_rules = [ 0 .. (length starts' - 1) ] +> used_rules = start_rules ++ +> nub [ r | (_,a) <- actions, r <- extract_reductions a ] +> used_tokens = errorTok : eof : +> nub [ t | (t,a) <- actions, is_shift a ] +> n_prods = length productions' +> unused_terminals = filter (`notElem` used_tokens) terms +> unused_rules = filter (`notElem` used_rules ) [0..n_prods-1] + +> is_shift :: LRAction -> Bool +> is_shift (LR'Shift _ _) = True +> is_shift (LR'Multiple _ LR'Shift{}) = True +> is_shift _ = False + +--- +selects what counts as a reduction when calculating used/unused + +> any_reduction :: LRAction -> [Int] +> any_reduction (LR'Reduce r _) = [r] +> any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as) +> any_reduction _ = [] + +> first_reduction :: LRAction -> [Int] +> first_reduction (LR'Reduce r _) = [r] +> first_reduction (LR'Multiple _ a) = first_reduction a -- eg R/R conflict +> first_reduction _ = [] \ No newline at end of file diff --git a/src/First.lhs b/packages/tabular/src/Happy/Tabular/First.lhs similarity index 73% rename from src/First.lhs rename to packages/tabular/src/Happy/Tabular/First.lhs index 9e93ac1b..072fe8b3 100644 --- a/src/First.lhs +++ b/packages/tabular/src/Happy/Tabular/First.lhs @@ -4,12 +4,11 @@ Implementation of FIRST (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- -> module First ( mkFirst ) where +> module Happy.Tabular.First ( mkFirst, mkClosure ) where -> import GenUtils -> import NameSet ( NameSet ) -> import qualified NameSet as Set -> import Grammar +> import Happy.Tabular.NameSet ( NameSet ) +> import qualified Happy.Tabular.NameSet as Set +> import Happy.Grammar.Grammar > import Data.IntSet (IntSet) \subsection{Utilities} @@ -21,6 +20,17 @@ Implementation of FIRST > | Set.member epsilonTok h = Set.delete epsilonTok h `Set.union` b > | otherwise = h +@mkClosure@ makes a closure, when given a comparison and iteration loop. +Be careful, because if the functional always makes the object different, +This will never terminate. + +> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a +> mkClosure eq f = match . iterate f +> where +> match (a:b:_) | a `eq` b = a +> match (_:c) = match c +> match [] = error "Can't happen: match []" + \subsection{Implementation of FIRST} > mkFirst :: Grammar -> [Name] -> NameSet diff --git a/src/Info.lhs b/packages/tabular/src/Happy/Tabular/Info.lhs similarity index 93% rename from src/Info.lhs rename to packages/tabular/src/Happy/Tabular/Info.lhs index 977e901f..1d799928 100644 --- a/src/Info.lhs +++ b/packages/tabular/src/Happy/Tabular/Info.lhs @@ -4,14 +4,15 @@ Generating info files. (c) 1993-2001 Andy Gill, Simon Marlow ----------------------------------------------------------------------------- -> module Info (genInfoFile) where +> module Happy.Tabular.Info (genInfoFile) where -> import Paths_happy ( version ) -> import LALR ( Lr0Item(..) ) -> import GenUtils ( str, interleave, interleave' ) +> import Happy.Grammar.Grammar +> import Happy.Tabular.Tables +> import Happy.Tabular.LALR ( Lr0Item(..) ) +> import Paths_happy_tabular ( version ) > import Data.Set ( Set ) > import qualified Data.Set as Set hiding ( Set ) -> import Grammar + > import Data.Array > import Data.List (nub) @@ -222,3 +223,10 @@ Produce a file of parser information, useful for debugging the parser. > = str "-----------------------------------------------------------------------------\n" > . str s > . str "\n-----------------------------------------------------------------------------\n" + +> str :: String -> String -> String +> str = showString +> interleave :: String -> [String -> String] -> String -> String +> interleave s = foldr (\a b -> a . str s . b) id +> interleave' :: String -> [String -> String] -> String -> String +> interleave' s = foldr1 (\a b -> a . str s . b) \ No newline at end of file diff --git a/src/LALR.lhs b/packages/tabular/src/Happy/Tabular/LALR.lhs similarity index 98% rename from src/LALR.lhs rename to packages/tabular/src/Happy/Tabular/LALR.lhs index 1dc274cf..18576f16 100644 --- a/src/LALR.lhs +++ b/packages/tabular/src/Happy/Tabular/LALR.lhs @@ -5,18 +5,19 @@ Generation of LALR parsing tables. (c) 1997-2001 Simon Marlow ----------------------------------------------------------------------------- -> module LALR +> module Happy.Tabular.LALR > (genActionTable, genGotoTable, genLR0items, precalcClosure0, > propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts, -> Lr0Item(..), Lr1Item) +> Lr0Item(..), Lr1Item(..)) > where -> import GenUtils -> import Data.Set ( Set ) +> import Happy.Tabular.First ( mkClosure ) +> import Happy.Tabular.NameSet ( NameSet ) +> import qualified Happy.Tabular.NameSet as NameSet +> import Happy.Grammar.Grammar +> import Happy.Tabular.Tables > import qualified Data.Set as Set hiding ( Set ) -> import qualified NameSet -> import NameSet ( NameSet ) -> import Grammar +> import Data.Set ( Set ) > import Control.Monad (guard) > import Control.Monad.ST @@ -35,24 +36,11 @@ Generation of LALR parsing tables. This means rule $a$, with dot at $b$ (all starting at 0) > data Lr0Item = Lr0 {-#UNPACK#-}!Int {-#UNPACK#-}!Int -- (rule, dot) -> deriving (Eq,Ord - -#ifdef DEBUG - -> ,Show - -#endif - -> ) +> deriving (Eq,Ord,Show) > data Lr1Item = Lr1 {-#UNPACK#-}!Int {-#UNPACK#-}!Int NameSet -- (rule, dot, lookahead) - -#ifdef DEBUG - > deriving (Show) -#endif - > type RuleList = [Lr0Item] ----------------------------------------------------------------------------- diff --git a/src/NameSet.hs b/packages/tabular/src/Happy/Tabular/NameSet.hs similarity index 73% rename from src/NameSet.hs rename to packages/tabular/src/Happy/Tabular/NameSet.hs index ea575d6a..c95c86f9 100644 --- a/src/NameSet.hs +++ b/packages/tabular/src/Happy/Tabular/NameSet.hs @@ -1,4 +1,4 @@ -module NameSet ( +module Happy.Tabular.NameSet ( NameSet, module Data.IntSet ) where diff --git a/packages/tabular/src/Happy/Tabular/Tables.lhs b/packages/tabular/src/Happy/Tabular/Tables.lhs new file mode 100644 index 00000000..0a3bc51b --- /dev/null +++ b/packages/tabular/src/Happy/Tabular/Tables.lhs @@ -0,0 +1,24 @@ +Datatypes for goto and action tables which are consumed by happy-backend. + +> module Happy.Tabular.Tables ( +> LRAction(..), ActionTable, Goto(..), GotoTable +> ) where + +> import Happy.Grammar.Grammar + +> import Data.Array + +> data LRAction = LR'Shift Int Priority -- state number and priority +> | LR'Reduce Int Priority-- rule no and priority +> | LR'Accept -- :-) +> | LR'Fail -- :-( +> | LR'MustFail -- :-( +> | LR'Multiple [LRAction] LRAction -- conflict +> deriving (Eq, Show) + +> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction) + +> data Goto = Goto Int | NoGoto +> deriving(Eq, Show) + +> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto) diff --git a/packages/test/LICENSE b/packages/test/LICENSE new file mode 120000 index 00000000..30cff740 --- /dev/null +++ b/packages/test/LICENSE @@ -0,0 +1 @@ +../../LICENSE \ No newline at end of file diff --git a/packages/test/Setup.hs b/packages/test/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/test/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tests/.gitignore b/packages/test/data/.gitignore similarity index 100% rename from tests/.gitignore rename to packages/test/data/.gitignore diff --git a/tests/AttrGrammar001.y b/packages/test/data/AttrGrammar001.y similarity index 94% rename from tests/AttrGrammar001.y rename to packages/test/data/AttrGrammar001.y index 4454dd6f..cd7ef733 100644 --- a/tests/AttrGrammar001.y +++ b/packages/test/data/AttrGrammar001.y @@ -1,5 +1,6 @@ { import Control.Monad (unless) +import System.Exit (exitFailure) } %tokentype { Char } @@ -64,5 +65,5 @@ main = case parse "" of { Just _ -> _ -> quit } ; _ -> quit }; _ -> quit }; _ -> quit } ; _ -> quit }; _ -> quit } -quit = putStrLn "Test failed" +quit = putStrLn "Test failed" >> exitFailure } diff --git a/tests/AttrGrammar002.y b/packages/test/data/AttrGrammar002.y similarity index 93% rename from tests/AttrGrammar002.y rename to packages/test/data/AttrGrammar002.y index 60419519..985df953 100644 --- a/tests/AttrGrammar002.y +++ b/packages/test/data/AttrGrammar002.y @@ -1,3 +1,6 @@ +{ +import System.Exit (exitFailure) +} %tokentype { Char } @@ -54,5 +57,5 @@ main = case parse "" of { Nothing -> _ -> quit }; _ -> quit }; _ -> quit }; _ -> quit } -quit = putStrLn "Test Failed" +quit = putStrLn "Test Failed" >> exitFailure } diff --git a/tests/ParGF.y b/packages/test/data/ParGF.y similarity index 100% rename from tests/ParGF.y rename to packages/test/data/ParGF.y diff --git a/tests/Partial.ly b/packages/test/data/Partial.ly similarity index 98% rename from tests/Partial.ly rename to packages/test/data/Partial.ly index f8d42e19..60e1730e 100644 --- a/tests/Partial.ly +++ b/packages/test/data/Partial.ly @@ -5,6 +5,7 @@ and the type of the tokens the parser reads. > { > import Data.Char +> import System.Exit (exitFailure) > } > %name calc Exp @@ -158,6 +159,6 @@ Here we test our parser. > Times (Times (Factor (Int 1)) (Int 2)) (Int 3) -> > print "Test works\n"; > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } -> quit = print "Test failed\n" +> quit = print "Test failed\n" >> exitFailure > } diff --git a/tests/Test.ly b/packages/test/data/Test.ly similarity index 97% rename from tests/Test.ly rename to packages/test/data/Test.ly index b32a0e38..e1f19fb1 100644 --- a/tests/Test.ly +++ b/packages/test/data/Test.ly @@ -5,6 +5,7 @@ and the type of the tokens the parser reads. > { > import Data.Char +> import System.Exit (exitFailure) > } > %name calc @@ -147,6 +148,6 @@ Here we test our parser. > case runCalc "let x = 2 in x * (x - 2)" of { > (Let "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n"; > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } -> quit = print "Test failed\n" +> quit = print "Test failed\n" >> exitFailure > } diff --git a/tests/TestMulti.ly b/packages/test/data/TestMulti.ly similarity index 98% rename from tests/TestMulti.ly rename to packages/test/data/TestMulti.ly index dadccbd5..21e9d416 100644 --- a/tests/TestMulti.ly +++ b/packages/test/data/TestMulti.ly @@ -5,6 +5,7 @@ and the type of the tokens the parser reads. > { > import Data.Char +> import System.Exit (exitFailure) > } > %name calcExp Exp @@ -154,6 +155,6 @@ Here we test our parser. > case runCalcTerm "2 * (3 + 1)" of { > (Times (Factor (Int 2)) (Brack (Exp1 (Plus (Term (Factor (Int 3))) (Factor (Int 1)))))) -> print "Test works\n"; > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } -> quit = print "Test failed\n" +> quit = print "Test failed\n" >> exitFailure > } diff --git a/tests/TestPrecedence.ly b/packages/test/data/TestPrecedence.ly similarity index 97% rename from tests/TestPrecedence.ly rename to packages/test/data/TestPrecedence.ly index c2cfb98d..b3b3b75c 100644 --- a/tests/TestPrecedence.ly +++ b/packages/test/data/TestPrecedence.ly @@ -5,6 +5,7 @@ and the type of the tokens the parser reads. > { > import Data.Char +> import System.Exit (exitFailure) > } > %name calc @@ -139,6 +140,6 @@ Here we test our parser. > print "Test works\n"; > _ -> quit } ; _ -> quit } ; _ -> quit } > -> quit = print "Test failed\n"; +> quit = print "Test failed\n" >> exitFailure > > } diff --git a/tests/bogus-token.y b/packages/test/data/bogus-token.y similarity index 100% rename from tests/bogus-token.y rename to packages/test/data/bogus-token.y diff --git a/tests/bug001.ly b/packages/test/data/bug001.ly similarity index 100% rename from tests/bug001.ly rename to packages/test/data/bug001.ly diff --git a/tests/bug002.y b/packages/test/data/bug002.y similarity index 100% rename from tests/bug002.y rename to packages/test/data/bug002.y diff --git a/tests/issue91.y b/packages/test/data/issue91.y similarity index 100% rename from tests/issue91.y rename to packages/test/data/issue91.y diff --git a/tests/issue93.y b/packages/test/data/issue93.y similarity index 100% rename from tests/issue93.y rename to packages/test/data/issue93.y diff --git a/tests/issue94.y b/packages/test/data/issue94.y similarity index 100% rename from tests/issue94.y rename to packages/test/data/issue94.y diff --git a/tests/issue95.y b/packages/test/data/issue95.y similarity index 100% rename from tests/issue95.y rename to packages/test/data/issue95.y diff --git a/tests/monad001.y b/packages/test/data/monad001.y similarity index 100% rename from tests/monad001.y rename to packages/test/data/monad001.y diff --git a/tests/monad002.ly b/packages/test/data/monad002.ly similarity index 95% rename from tests/monad002.ly rename to packages/test/data/monad002.ly index 35cc5b0b..0991b21b 100644 --- a/tests/monad002.ly +++ b/packages/test/data/monad002.ly @@ -6,6 +6,7 @@ Test for monadic Happy Parsers, Simon Marlow 1996. > -- -fglasgow-exts required because P is a type synonym, and Happy uses it > -- unsaturated. > import Data.Char +> import System.Exit (exitFailure) > } > %name calc @@ -135,7 +136,10 @@ The following functions should be defined for all parsers. This is the overall type of the parser. > type Parse = P Exp -> calc :: Parse +> calc_test_sig :: Parse +> calc_test_sig = calc + +(We use a fresh name because `calc` might already have a sig depending on the backend.) The next function is called when a parse error is detected. It has the same type as the top-level parse function. @@ -157,5 +161,5 @@ Here we test our parser. > case runCalc "let x = 2 in x * (x - 2)" of { > (Let 1 "x" (Exp1 (Term (Factor (Int 2)))) (Exp1 (Term (Times (Factor (Var "x")) (Brack (Exp1 (Minus (Term (Factor (Var "x"))) (Factor (Int 2))))))))) -> print "Test works\n"; > _ -> quit } ; _ -> quit } ; _ -> quit } ; _ -> quit } -> quit = print "Test failed\n" +> quit = print "Test failed\n" >> exitFailure > } diff --git a/tests/monaderror-explist.y b/packages/test/data/monaderror-explist.y similarity index 93% rename from tests/monaderror-explist.y rename to packages/test/data/monaderror-explist.y index 558f28ee..5051fc1b 100644 --- a/tests/monaderror-explist.y +++ b/packages/test/data/monaderror-explist.y @@ -1,8 +1,5 @@ { -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} --- For ancient GHC 7.0.4 -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies, FlexibleInstances, MultiParamTypeClasses #-} module Main where import Data.Char diff --git a/tests/monaderror.y b/packages/test/data/monaderror.y similarity index 90% rename from tests/monaderror.y rename to packages/test/data/monaderror.y index f2e6fef9..301d9299 100644 --- a/tests/monaderror.y +++ b/packages/test/data/monaderror.y @@ -1,8 +1,5 @@ { -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} --- For ancient GHC 7.0.4 -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies, FlexibleInstances, MultiParamTypeClasses #-} module Main where import Control.Monad (when) diff --git a/tests/precedence001.ly b/packages/test/data/precedence001.ly similarity index 100% rename from tests/precedence001.ly rename to packages/test/data/precedence001.ly diff --git a/tests/precedence002.y b/packages/test/data/precedence002.y similarity index 100% rename from tests/precedence002.y rename to packages/test/data/precedence002.y diff --git a/tests/rank2.y b/packages/test/data/rank2.y similarity index 100% rename from tests/rank2.y rename to packages/test/data/rank2.y diff --git a/tests/shift01.y b/packages/test/data/shift01.y similarity index 100% rename from tests/shift01.y rename to packages/test/data/shift01.y diff --git a/tests/test_rules.y b/packages/test/data/test_rules.y similarity index 100% rename from tests/test_rules.y rename to packages/test/data/test_rules.y diff --git a/tests/typeclass_monad001.y b/packages/test/data/typeclass_monad001.y similarity index 100% rename from tests/typeclass_monad001.y rename to packages/test/data/typeclass_monad001.y diff --git a/tests/typeclass_monad002.ly b/packages/test/data/typeclass_monad002.ly similarity index 98% rename from tests/typeclass_monad002.ly rename to packages/test/data/typeclass_monad002.ly index 677a928b..e19d1e10 100644 --- a/tests/typeclass_monad002.ly +++ b/packages/test/data/typeclass_monad002.ly @@ -6,6 +6,7 @@ Test for monadic Happy Parsers, Simon Marlow 1996. > -- -fglasgow-exts required because P is a type synonym, and Happy uses it > -- unsaturated. > import Data.Char +> import System.Exit (exitFailure) > } > %name calc @@ -181,5 +182,5 @@ Here we test our parser. > _ -> quit > _ -> quit > _ -> quit -> quit = print "Test failed\n" +> quit = print "Test failed\n" >> exitFailure > } diff --git a/tests/typeclass_monad_lexer.y b/packages/test/data/typeclass_monad_lexer.y similarity index 95% rename from tests/typeclass_monad_lexer.y rename to packages/test/data/typeclass_monad_lexer.y index 7f55be69..9bc9340a 100644 --- a/tests/typeclass_monad_lexer.y +++ b/packages/test/data/typeclass_monad_lexer.y @@ -1,9 +1,5 @@ { -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} --- For ancient GHC 7.0.4 -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-} import Control.Monad (liftM, ap) import Control.Applicative as A } diff --git a/packages/test/happy-test.cabal b/packages/test/happy-test.cabal new file mode 100644 index 00000000..b63da214 --- /dev/null +++ b/packages/test/happy-test.cabal @@ -0,0 +1,79 @@ +name: happy-test +version: 1.21.0 +license: BSD2 +license-file: LICENSE +copyright: (c) Andy Gill, Simon Marlow +author: Andy Gill and Simon Marlow +maintainer: Simon Marlow +bug-reports: https://github.com/simonmar/happy/issues +stability: stable +homepage: https://www.haskell.org/happy/ +category: Development +cabal-version: >= 1.10 +build-type: Simple +synopsis: Testing for happy + +Description: + Happy is a parser generator for Haskell. + Happy-Test hosts various test grammars and allows + to customize and execute the happy test suite. + +tested-with: + GHC == 7.0.4 + GHC == 7.4.2 + GHC == 7.6.3 + GHC == 7.8.4 + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.4 + GHC == 9.0.1 + +data-dir: data + +data-files: + AttrGrammar001.y + AttrGrammar002.y + Partial.ly + Test.ly + TestMulti.ly + TestPrecedence.ly + bogus-token.y + bug001.ly + bug002.y + monad001.y + monad002.ly + monaderror.y + precedence001.ly + precedence002.y + test_rules.y + issue91.y + issue93.y + issue94.y + issue95.y + monaderror-explist.y + typeclass_monad001.y + typeclass_monad002.ly + typeclass_monad_lexer.y + rank2.y + shift01.y + +library + hs-source-dirs: src + + exposed-modules: Happy.Test, + Happy.Test.SDist + build-depends: base < 5, + process, + directory, + filepath, + transformers >= 0.5.6.2 + + default-language: Haskell98 + default-extensions: CPP + ghc-options: -Wall + other-modules: Happy.Test.Shell, + Paths_happy_test diff --git a/packages/test/src/Happy/Test.hs b/packages/test/src/Happy/Test.hs new file mode 100644 index 00000000..263ee61e --- /dev/null +++ b/packages/test/src/Happy/Test.hs @@ -0,0 +1,85 @@ +module Happy.Test(test, TestSetup(..), defaultTestFiles, attributeGrammarTestFiles) where + +import Happy.Test.Shell +import System.IO +import System.FilePath +import Control.Exception +import System.Directory +import System.Exit +import Paths_happy_test + +data TestSetup = TestSetup { + happyExec :: String, -- name of the happy exeuctable which shall be tested. + haskellCompilerExec :: String, -- name of the haskell compiler which shall be used in tests. + defaultTests :: [String], -- standard tests from happy-test package that should be performed. these are in this package's data-dir + customTests :: [String], -- custom tests from the calling package that should be performed. these are in the calling package's data-dir + customDataDir :: String, -- data-dir of the calling package. all tests are compiled and executed in their respective directory. + allArguments :: [String], -- all different testable argument combinations for happy, as strings + stopOnFailure :: Bool -- continue with remaining tests after an error has occurred? +} + +test :: TestSetup -> IO a +test setup = do + hSetBuffering stdout NoBuffering -- required for cabal test + defaultDir <- getDataDir + let files = zip (repeat defaultDir) (defaultTests setup) ++ + zip (repeat (customDataDir setup)) (customTests setup) -- (dir, file.ly) + let tests = [(dir, file, arg) | (dir, file) <- files, arg <- allArguments setup] -- (dir, file.ly, -ag) + result <- test' tests (happyExec setup) (haskellCompilerExec setup) (stopOnFailure setup) + if result then exitSuccess else exitFailure + +-- Perform the tests given in the list, specified via (directory, file, happy-options). +test' :: [(String, String, String)] -> String -> String -> Bool -> IO Bool +test' [] _ _ _ = return True +test' ((dir, file, args):rest) happy haskellCompiler stopOnFail = do + result <- runSingleTest happy haskellCompiler args dir file + if result then test' rest happy haskellCompiler stopOnFail + else if stopOnFail + then return False + else do _ <- test' rest happy haskellCompiler stopOnFail; return False + +-- These test files do not use attribute grammars. +defaultTestFiles :: [String] +defaultTestFiles = ["Test.ly", "TestMulti.ly", "TestPrecedence.ly", "bug001.ly", "monad001.y", "monad002.ly", "precedence001.ly", + "precedence002.y", "bogus-token.y", "bug002.y", "Partial.ly", "issue91.y", "issue93.y", "issue94.y", "issue95.y", + "test_rules.y", "monaderror.y", "monaderror-explist.y", "typeclass_monad001.y", "typeclass_monad002.ly", + "typeclass_monad_lexer.y", "rank2.y", "shift01.y"] + +attributeGrammarTestFiles :: [String] +attributeGrammarTestFiles = ["AttrGrammar001.y", "AttrGrammar002.y"] + +runSingleTest :: String -> String -> String -> String -> String -> IO Bool +runSingleTest happy haskellCompiler arguments dir testFile = do + res <- runShell (do + runCmdIn dir [happy, testFile, arguments, "-o", hsFile] True ||| failure + runCmdIn dir [haskellCompiler, "-Wall", hsFile, "-o", binFile] True ||| failure + runCmd [dir binFile] True ||| failure + ) + + removeFiles + return res + where + hsFile = basename testFile ++ ".hs" + binFile = basename testFile ++ ".exe" + hiFile = basename testFile ++ ".hi" + oFile = basename testFile ++ ".o" + + removeFiles = do + let generated = map (combine dir) [hsFile, binFile, hiFile, oFile] + mapM_ tryRemovingFile generated + + failure = putStrLn $ "Test " ++ testFile ++ " failed!" + +tryRemovingFile :: FilePath -> IO () +tryRemovingFile file = do + removeFile file `catchIO` const (return ()) + where + catchIO :: IO a -> (IOError -> IO a) -> IO a + catchIO = Control.Exception.catch + +-- Only works for .y and .ly files. +basename :: FilePath -> FilePath +basename = reverse . basename' . reverse where + basename' ('y':'l':'.':file) = file + basename' ('y':'.':file) = file + basename' file = error $ "Error: test file does not end in .y or .ly: " ++ reverse file diff --git a/packages/test/src/Happy/Test/SDist.hs b/packages/test/src/Happy/Test/SDist.hs new file mode 100644 index 00000000..deb01190 --- /dev/null +++ b/packages/test/src/Happy/Test/SDist.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Happy.Test.SDist(sdist_test) where + +import Happy.Test.Shell +import System.FilePath +import System.Directory (setCurrentDirectory) +import System.Process +import System.Exit +import Data.Ord +import Data.List +import Data.Maybe +import Control.Applicative +import Control.Exception +import Control.Monad.IO.Class + +-- Test whether the tarballs are distribution-ready by calling `cabal sdist`, merging the tarballs into one umbrella directory and building and testing in this directory. +-- Arguments: +-- * absolute location of main project directory +-- * name of the main executable (which also provides a test suite) +-- * names of all required local packages (including the main executable) +-- * perform bootstrapping-testing? if true, first build without bootstrap, and then use the generated binary for bootstrapping. +sdist_test :: String -> String -> String -> [String] -> Bool -> IO () +sdist_test cabal projectDir executable localPackages bootstrapping = do + success <- runShell $ sdist_test' cabal projectDir executable localPackages bootstrapping + if success + then putStrLn "Success! The tarballs inside dist-newstyle/sdist are now ready for distribution." >> exitSuccess + else putStrLn "Failure." >> exitFailure + +sdist_test' :: String -> String -> String -> [String] -> Bool -> Shell +sdist_test' cabal projectDir executable localPackages bootstrapping = do + let sdistDir = joinPath [projectDir, "dist-newstyle", "sdist"] + + -- `cabal sdist all` -> returns `package-name-VERSION` for each package-name + fullNames <- cabalSdistAll cabal localPackages sdistDir + + liftIO . putStrLn $ "packages: " ++ show (zip localPackages fullNames) + + -- inside dist-newstyle/sdist: + -- `rm -rf package-name` + -- `tar -xf package-name.tar.gz` + -- `rm -rf umbrella; mkdir umbrella` + -- `mv package-name umbrella` + let rm = \name -> runCmdIn sdistDir ["rm", "-rf", name] False + let untar = \name -> runCmdIn sdistDir ["tar", "-xf", name ++ targz] False + let mkUmbrella = runCmdIn sdistDir ["rm -rf umbrella; mkdir umbrella"] False + let mv = \name -> runCmdIn sdistDir ["mv", name, "umbrella"] False + + -- inside umbrella: + -- `echo "packages: ..." > cabal.project` + let umbrellaDir = sdistDir "umbrella" + let packagesText = intercalate "\n " (["packages:"] ++ fullNames) ++ "\ntests: True" + let genCabalProj = runCmdIn umbrellaDir ["echo", "'" ++ packagesText ++ "'", ">", "cabal.project"] False + + -- Perform commands in sequence, stop on error + mapM_ rm fullNames + mapM_ untar fullNames + mkUmbrella + mapM_ mv fullNames + genCabalProj + + liftIO . putStrLn $ "Umbrella dir (" ++ umbrellaDir ++ ") generated successfully." + + if bootstrapping + then testWithBootstrapping cabal umbrellaDir executable + else testWithoutBootstrapping cabal umbrellaDir executable + + return () + +testWithoutBootstrapping :: String -> FilePath -> String -> Shell +testWithoutBootstrapping cabal dir executable = do + runCmdIn dir [cabal, "build", executable] False + runCmdIn dir [cabal, "test", executable] False + +testWithBootstrapping :: String -> FilePath -> String -> Shell +testWithBootstrapping cabal dir executable = do + runCmdIn dir [cabal, "build", executable, "-f", "-bootstrap"] False + runCmdIn dir [cabal, "install", executable, "-f", "-bootstrap", "--installdir=./bootstrap-root"] False + runCmdIn dir [cabal, "test", executable, "-f", "-bootstrap"] False + + -- We now want our just-built happy to be used for bootstrapping happy, i.e. building happy's .ly files. + -- Using `cabal build --with-happy=` (instead of exporting ./bootstrap-root to PATH) also allows using happy's with a different name like `happy-rad`. + let bootstrapHappy = joinPath [dir, "bootstrap-root", executable] + runCmdIn dir [cabal, "build", executable, "-f", "+bootstrap", "--with-happy=" ++ bootstrapHappy] False + runCmdIn dir [cabal, "test", executable, "-f", "+bootstrap"] False + +-- Perform `cabal sdist all` and match the output lines to the given package names. +-- This is required to extract the full package name (i.e. package-name-VERSION) for each package. +-- This is less elegant than performing `cabal sdist package` for each package on its own, but is required because `cabal sdist happy` doesn't work on its own - `cabal sdist all` does. +cabalSdistAll :: String -> [String] -> String -> TypedShell [String] +cabalSdistAll cabal packageNames baseDir = do + liftIO $ setCurrentDirectory baseDir + output <- liftIO $ readProcess cabal ["sdist", "all"] "" `catchIO` const (return "") + let fullNames = catMaybes . catMaybes $ map extractFullName $ lines output + let matched = catMaybes $ map (bestMatch fullNames) packageNames + if length packageNames == length matched then return matched else empty + where + catchIO :: IO a -> (IOError -> IO a) -> IO a + catchIO = Control.Exception.catch + + -- Find package-name-VERSION matching to package-name. + -- Note: we cannot just use `isPrefixOf` because then `happy` would match to `happy-frontend-1.21.0`! + bestMatch fullNames packageName = head' $ sortBy (comparing numPrefixMatches) prefixMatches where + prefixMatches = filter (isPrefixOf packageName) fullNames + numPrefixMatches fullName = length $ filter (flip isPrefixOf fullName) packageNames + + -- extract "package-name-VERSION" from a string containg "package-name-VERSION.tar.gz" + extractFullName output = + case (lastSubstring baseDir output, lastSubstring targz output) of + (Just i', Just j) -> let i = i' + 1 + length baseDir in return . Just $ take (j-i) $ drop i $ output + _ -> return Nothing + + -- the returned index is counted from the back so you can use `drop` with the result + lastSubstring search str = last' $ findIndices (isPrefixOf search) (tails str) + + head' x = if null x then Nothing else Just (head x) + last' x = if null x then Nothing else Just (last x) + +targz :: String +targz = ".tar.gz" diff --git a/packages/test/src/Happy/Test/Shell.hs b/packages/test/src/Happy/Test/Shell.hs new file mode 100644 index 00000000..e3cced86 --- /dev/null +++ b/packages/test/src/Happy/Test/Shell.hs @@ -0,0 +1,55 @@ +module Happy.Test.Shell where + +import System.Directory +import System.Process +import System.Exit +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Control.Applicative + +type TypedShell a = MaybeT IO a +type Shell = TypedShell () + +-- Perform a sequence of Shell operations, stopping when one fails. +runShell :: Shell -> IO Bool +runShell s = fmap (Nothing /=) (runMaybeT s) + +-- Perform a; if a fails, perform b as cleanup, but still fail the operation. +(|||) :: TypedShell a -> IO b -> TypedShell a +a ||| b = MaybeT { runMaybeT = run } + where run = do + result <- runMaybeT a + case result of + Just val -> return $ Just val + Nothing -> b >>= (\_ -> return Nothing) +infixr 2 ||| + +-- Run a shell command. Succeed when exit code = 0. Ignore the command's output. +runCmd :: [String] -> Bool -> Shell +runCmd args verbose = do + let cmd = unwords args + when verbose (liftIO $ putStrLn cmd) + exitCode <- liftIO $ system cmd + if exitCode == ExitSuccess + then return () + else empty + +-- Run a shell command inside a given directory. Succeed when exit code = 0. Ignore the command's output. +runCmdIn :: FilePath -> [String] -> Bool -> Shell +runCmdIn dir args verbose = do + when verbose (liftIO . putStr $ "Inside " ++ dir ++ ": ") + liftIO $ setCurrentDirectory dir + runCmd args verbose + +runCmd' :: [String] -> Bool -> IO Bool +runCmd' args verbose = runShell (runCmd args verbose) + +runCmdIn' :: String -> [String] -> Bool -> IO Bool +runCmdIn' dir args verbose = runShell (runCmdIn dir args verbose) + +-- dropWhileEnd only exists since base-4.5.0.0, i.e. GHC 7.4.1 +#if !MIN_VERSION_base(4,5,0) +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] +#endif \ No newline at end of file diff --git a/src/GenUtils.lhs b/src/GenUtils.lhs deleted file mode 100644 index 66ae2c39..00000000 --- a/src/GenUtils.lhs +++ /dev/null @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------ -Some General Utilities, including sorts, etc. -This is realy just an extended prelude. -All the code below is understood to be in the public domain. ------------------------------------------------------------------------------ - -> module GenUtils ( - -> mkClosure, -> combinePairs, -> mapDollarDollar, -> str, char, nl, brack, brack', -> interleave, interleave', -> strspace, maybestr -> ) where - -> import Data.Char (isAlphaNum) -> import Data.Ord (comparing) -> import Data.List (sortBy) - -%------------------------------------------------------------------------------ - -@mkClosure@ makes a closure, when given a comparison and iteration loop. -Be careful, because if the functional always makes the object different, -This will never terminate. - -> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a -> mkClosure eq f = match . iterate f -> where -> match (a:b:_) | a `eq` b = a -> match (_:c) = match c -> match [] = error "Can't happen: match []" - - -Gofer-like stuff: - -> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])] -> combinePairs xs = -> combine [ (a,[b]) | (a,b) <- sortBy (comparing fst) xs] -> where -> combine [] = [] -> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r) -> combine (a:r) = a : combine r -> - - -Replace $$ with an arbitrary string, being careful to avoid ".." and '.'. - -> mapDollarDollar :: String -> Maybe (String -> String) -> mapDollarDollar code0 = go code0 "" -> where go code acc = -> case code of -> [] -> Nothing -> -> '"' :r -> case reads code :: [(String,String)] of -> [] -> go r ('"':acc) -> (s,r'):_ -> go r' (reverse (show s) ++ acc) -> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc) -> '\'' :r -> case reads code :: [(Char,String)] of -> [] -> go r ('\'':acc) -> (c,r'):_ -> go r' (reverse (show c) ++ acc) -> '\\':'$':r -> go r ('$':acc) -> '$':'$':r -> Just (\repl -> reverse acc ++ repl ++ r) -> c:r -> go r (c:acc) - - -%------------------------------------------------------------------------------- -Fast string-building functions. - -> str :: String -> String -> String -> str = showString -> char :: Char -> String -> String -> char c = (c :) -> interleave :: String -> [String -> String] -> String -> String -> interleave s = foldr (\a b -> a . str s . b) id -> interleave' :: String -> [String -> String] -> String -> String -> interleave' s = foldr1 (\a b -> a . str s . b) - -> strspace :: String -> String -> strspace = char ' ' -> nl :: String -> String -> nl = char '\n' - -> maybestr :: Maybe String -> String -> String -> maybestr (Just s) = str s -> maybestr _ = id - -> brack :: String -> String -> String -> brack s = str ('(' : s) . char ')' -> brack' :: (String -> String) -> String -> String -> brack' s = char '(' . s . char ')' diff --git a/src/Main.lhs b/src/Main.lhs deleted file mode 100644 index 195ab732..00000000 --- a/src/Main.lhs +++ /dev/null @@ -1,592 +0,0 @@ ------------------------------------------------------------------------------ -The main driver. - -(c) 1993-2003 Andy Gill, Simon Marlow -GLR amendments (c) University of Durham, Ben Medlock 2001 ------------------------------------------------------------------------------ - -> module Main (main) where - -Path settings auto-generated by Cabal: - -> import Paths_happy - -> import ParseMonad.Class -> import AbsSyn -> import Grammar -> import PrettyGrammar -> import Parser - -> import First -> import LALR -> import ProduceCode (produceParser) -> import ProduceGLRCode -> import Info (genInfoFile) -> import Target (Target(..)) -> import System.Console.GetOpt -> import Control.Monad ( liftM ) -> import System.Environment -> import System.Exit (exitWith, ExitCode(..)) -> import Data.Char -> import System.IO -> import Data.Array( assocs, elems, (!) ) -> import Data.List( nub, isSuffixOf ) -> import Data.Version ( showVersion ) - -> main :: IO () -> main = do - -Read and parse the CLI arguments. - -> args <- getArgs -> main2 args - -> main2 :: [String] -> IO () -> main2 args = - -Read and parse the CLI arguments. - -> case getOpt Permute argInfo (constArgs ++ args) of -> (cli,_,[]) | DumpVersion `elem` cli -> -> bye copyright -> (cli,_,[]) | DumpHelp `elem` cli -> do -> prog <- getProgramName -> bye (usageInfo (usageHeader prog) argInfo) -> (cli,_,_) | OptDebugParser `elem` cli -> && OptArrayTarget `notElem` cli -> do -> die "Cannot use debugging without -a\n" -> (cli,[fl_name],[]) -> -> runParserGen cli fl_name -> (_,_,errors) -> do -> prog <- getProgramName -> die (concat errors ++ -> usageInfo (usageHeader prog) argInfo) - -> where -> runParserGen cli fl_name = do - -Open the file. - -> fl <- readFile fl_name -> (file,name) <- possDelit (reverse fl_name) fl - -Parse, using bootstrapping parser. - -> (abssyn, hd, tl) <- case runFromStartP ourParser file 1 of -> Left err -> die (fl_name ++ ':' : err) -> Right abssyn@(AbsSyn hd _ _ tl) -> return (abssyn, hd, tl) - -Mangle the syntax into something useful. - -> g <- case {-# SCC "Mangler" #-} (mangler fl_name abssyn) of -> Left s -> die (unlines s ++ "\n"); -> Right g -> return g - -#ifdef DEBUG - -> optPrint cli DumpMangle $ putStr $ show g - -#endif - -> let first = {-# SCC "First" #-} (mkFirst g) -> closures = {-# SCC "Closures" #-} (precalcClosure0 g) -> sets = {-# SCC "LR0_Sets" #-} (genLR0items g closures) -> _lainfo@(spont,prop) = {-# SCC "Prop" #-} (propLookaheads g sets first) -> la = {-# SCC "Calc" #-} (calcLookaheads (length sets) spont prop) -> items2 = {-# SCC "Merge" #-} (mergeLookaheadInfo la sets) -> goto = {-# SCC "Goto" #-} (genGotoTable g sets) -> action = {-# SCC "Action" #-} (genActionTable g first items2) -> (conflictArray,(sr,rr)) = {-# SCC "Conflict" #-} (countConflicts action) - -#ifdef DEBUG - -> optPrint cli DumpLR0 $ putStr $ show sets -> optPrint cli DumpAction $ putStr $ show action -> optPrint cli DumpGoto $ putStr $ show goto -> optPrint cli DumpLA $ putStr $ show _lainfo -> optPrint cli DumpLA $ putStr $ show la - -#endif - -Report any unused rules and terminals - -> let reduction_filter | OptGLR `elem` cli = any_reduction -> | otherwise = first_reduction -> (unused_rules, unused_terminals) -> = find_redundancies reduction_filter g action -> optIO (not (null unused_rules)) -> (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules))) -> optIO (not (null unused_terminals)) -> (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals))) - -Print out the info file. - -> info_filename <- getInfoFileName name cli -> let info = genInfoFile -> (map fst sets) -> g -> action -> goto -> (token_specs g) -> conflictArray -> fl_name -> unused_rules -> unused_terminals -> case info_filename of -> Just s -> do -> writeFile s info -> hPutStrLn stderr ("Grammar info written to: " ++ s) -> Nothing -> return () - - -Pretty print the grammar. - -> pretty_filename <- getPrettyFileName name cli -> case pretty_filename of -> Just s -> do -> let out = render (ppAbsSyn abssyn) -> writeFile s out -> hPutStrLn stderr ("Production rules written to: " ++ s) -> Nothing -> return () - -Report any conflicts in the grammar. - -> case expect g of -> Just n | n == sr && rr == 0 -> return () -> Just _ | rr > 0 -> -> die ("The grammar has reduce/reduce conflicts.\n" ++ -> "This is not allowed when an expect directive is given\n") -> Just _ -> -> die ("The grammar has " ++ show sr ++ -> " shift/reduce conflicts.\n" ++ -> "This is different from the number given in the " ++ -> "expect directive\n") -> _ -> do - -> (if sr /= 0 -> then hPutStrLn stderr ("shift/reduce conflicts: " ++ show sr) -> else return ()) - -> (if rr /= 0 -> then hPutStrLn stderr ("reduce/reduce conflicts: " ++ show rr) -> else return ()) - - - - -Now, let's get on with generating the parser. Firstly, find out what kind -of code we should generate, and where it should go: - -> target <- getTarget cli -> outfilename <- getOutputFileName fl_name cli -> template' <- getTemplate getDataDir cli -> opt_coerce <- getCoerce target cli -> opt_strict <- getStrict cli -> opt_array <- getArray cli -> opt_ghc <- getGhc cli - -Add any special options or imports required by the parsing machinery. - -> let -> header = Just $ -> (case hd of Just s -> s; Nothing -> "") -> ++ importsToInject cli - - -%--------------------------------------- -Branch off to GLR parser production - -> let glr_decode | OptGLR_Decode `elem` cli = TreeDecode -> | otherwise = LabelDecode -> filtering | OptGLR_Filter `elem` cli = UseFiltering -> | otherwise = NoFiltering -> ghc_exts | OptGhcTarget `elem` cli = UseGhcExts -> (importsToInject cli) - -Unlike below, don't always passs CPP, because only one of the files needs it. - -> (langExtsToInject cli) -> | otherwise = NoGhcExts -> debug = OptDebugParser `elem` cli -> if OptGLR `elem` cli -> then produceGLRParser -> outfilename -- specified output file name -> template' -- template files directory -> action -- action table (:: ActionTable) -> goto -- goto table (:: GotoTable) -> header -- header from grammar spec -> tl -- trailer from grammar spec -> (debug, (glr_decode,filtering,ghc_exts)) -> -- controls decoding code-gen -> g -- grammar object -> else do - - -%--------------------------------------- -Resume normal (ie, non-GLR) processing - -> let -> template = template' ++ "/HappyTemplate.hs" - -Read in the template file for this target: - -> templ <- readFile template - -and generate the code. - -> magic_name <- getMagicName cli -> let -> outfile = produceParser -> g -> action -> goto - -CPP is needed in all cases with unified template - -> ("CPP" : langExtsToInject cli) -> header -> tl -> target -> opt_coerce -> opt_ghc -> opt_strict -> magic_filter = -> case magic_name of -> Nothing -> id -> Just name' -> -> let -> small_name = name' -> big_name = toUpper (head name') : tail name' -> filter_output ('h':'a':'p':'p':'y':rest) = -> small_name ++ filter_output rest -> filter_output ('H':'a':'p':'p':'y':rest) = -> big_name ++ filter_output rest -> filter_output (c:cs) = c : filter_output cs -> filter_output [] = [] -> in -> filter_output - -> vars_to_define = concat -> [ [ "HAPPY_DEBUG" | debug ] -> , [ "HAPPY_ARRAY" | opt_array ] -> , [ "HAPPY_GHC" | opt_ghc ] -> , [ "HAPPY_COERCE" | opt_coerce ] -> ] -> defines = unlines -> [ "#define " ++ d ++ " 1" | d <- vars_to_define ] - -> (if outfilename == "-" then putStr else writeFile outfilename) -> (magic_filter (outfile ++ defines ++ templ)) - -Successfully Finished. - ------------------------------------------------------------------------------ - -> getProgramName :: IO String -> getProgramName = liftM (`withoutSuffix` ".bin") getProgName -> where str' `withoutSuffix` suff -> | suff `isSuffixOf` str' = take (length str' - length suff) str' -> | otherwise = str' - -> bye :: String -> IO a -> bye s = putStr s >> exitWith ExitSuccess - -> die :: String -> IO a -> die s = hPutStr stderr s >> exitWith (ExitFailure 1) - -> dieHappy :: String -> IO a -> dieHappy s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) - -> optIO :: Bool -> IO a -> IO a -> optIO fg io = if fg then io else return (error "optIO") - -#ifdef DEBUG -> optPrint :: [CLIFlags] -> CLIFlags -> IO () -> IO () -> optPrint cli pass io = -> optIO (elem pass cli) (putStr "\n---------------------\n" >> io) -#endif - -> constArgs :: [String] -> constArgs = [] - ------------------------------------------------------------------------------ -Find unused rules and tokens - -> find_redundancies -> :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String]) -> find_redundancies extract_reductions g action_table = -> (unused_rules, map (env !) unused_terminals) -> where -> Grammar { terminals = terms, -> token_names = env, -> eof_term = eof, -> starts = starts', -> productions = productions' -> } = g - -> actions = concat (map assocs (elems action_table)) -> start_rules = [ 0 .. (length starts' - 1) ] -> used_rules = start_rules ++ -> nub [ r | (_,a) <- actions, r <- extract_reductions a ] -> used_tokens = errorTok : eof : -> nub [ t | (t,a) <- actions, is_shift a ] -> n_prods = length productions' -> unused_terminals = filter (`notElem` used_tokens) terms -> unused_rules = filter (`notElem` used_rules ) [0..n_prods-1] - -> is_shift :: LRAction -> Bool -> is_shift (LR'Shift _ _) = True -> is_shift (LR'Multiple _ LR'Shift{}) = True -> is_shift _ = False - ---- -selects what counts as a reduction when calculating used/unused - -> any_reduction :: LRAction -> [Int] -> any_reduction (LR'Reduce r _) = [r] -> any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as) -> any_reduction _ = [] - -> first_reduction :: LRAction -> [Int] -> first_reduction (LR'Reduce r _) = [r] -> first_reduction (LR'Multiple _ a) = first_reduction a -- eg R/R conflict -> first_reduction _ = [] - ------------------------------------------------------------------------------- - -> possDelit :: String -> String -> IO (String,String) -> possDelit ('y':'l':'.':nm) fl = return (deLitify fl,reverse nm) -> possDelit ('y':'.':nm) fl = return (fl,reverse nm) -> possDelit f _ = -> dieHappy ("`" ++ reverse f ++ "' does not end in `.y' or `.ly'\n") - -> deLitify :: String -> String -> deLitify = deLit -> where -> deLit ('>':' ':r) = deLit1 r -> deLit ('>':'\t':r) = '\t' : deLit1 r -> deLit ('>':'\n':r) = deLit r -> deLit ('>':_) = error "Error when de-litify-ing" -> deLit ('\n':r) = '\n' : deLit r -> deLit r = deLit2 r -> deLit1 ('\n':r) = '\n' : deLit r -> deLit1 (c:r) = c : deLit1 r -> deLit1 [] = [] -> deLit2 ('\n':r) = '\n' : deLit r -> deLit2 (_:r) = deLit2 r -> deLit2 [] = [] - ------------------------------------------------------------------------------- -The command line arguments. - -> data CLIFlags = -#ifdef DEBUG -> DumpMangle -> | DumpLR0 -> | DumpAction -> | DumpGoto -> | DumpLA -> -> | -#endif -> DumpVersion -> | DumpHelp -> | OptInfoFile (Maybe String) -> | OptPrettyFile (Maybe String) -> | OptTemplate String -> | OptMagicName String -> -> | OptGhcTarget -> | OptArrayTarget -> | OptUseCoercions -> | OptDebugParser -> | OptStrict -> | OptOutputFile String -> | OptGLR -> | OptGLR_Decode -> | OptGLR_Filter -> deriving Eq - -> argInfo :: [OptDescr CLIFlags] -> argInfo = [ -> Option ['o'] ["outfile"] (ReqArg OptOutputFile "FILE") -> "write the output to FILE (default: file.hs)", -> Option ['i'] ["info"] (OptArg OptInfoFile "FILE") -> "put detailed grammar info in FILE", -> Option ['p'] ["pretty"] (OptArg OptPrettyFile "FILE") -> "pretty print the production rules to FILE", -> Option ['t'] ["template"] (ReqArg OptTemplate "DIR") -> "look in DIR for template files", -> Option ['m'] ["magic-name"] (ReqArg OptMagicName "NAME") -> "use NAME as the symbol prefix instead of \"happy\"", -> Option ['s'] ["strict"] (NoArg OptStrict) -> "evaluate semantic values strictly (experimental)", -> Option ['g'] ["ghc"] (NoArg OptGhcTarget) -> "use GHC extensions", -> Option ['c'] ["coerce"] (NoArg OptUseCoercions) -> "use type coercions (only available with -g)", -> Option ['a'] ["array"] (NoArg OptArrayTarget) -> "generate an array-based parser", -> Option ['d'] ["debug"] (NoArg OptDebugParser) -> "produce a debugging parser (only with -a)", -> Option ['l'] ["glr"] (NoArg OptGLR) -> "Generate a GLR parser for ambiguous grammars", -> Option ['k'] ["decode"] (NoArg OptGLR_Decode) -> "Generate simple decoding code for GLR result", -> Option ['f'] ["filter"] (NoArg OptGLR_Filter) -> "Filter the GLR parse forest with respect to semantic usage", -> Option ['?'] ["help"] (NoArg DumpHelp) -> "display this help and exit", -> Option ['V','v'] ["version"] (NoArg DumpVersion) -- ToDo: -v is deprecated -> "output version information and exit" - -#ifdef DEBUG - -Various debugging/dumping options... - -> , -> Option [] ["mangle"] (NoArg DumpMangle) -> "Dump mangled input", -> Option [] ["lr0"] (NoArg DumpLR0) -> "Dump LR0 item sets", -> Option [] ["action"] (NoArg DumpAction) -> "Dump action table", -> Option [] ["goto"] (NoArg DumpGoto) -> "Dump goto table", -> Option [] ["lookaheads"] (NoArg DumpLA) -> "Dump lookahead info" - -#endif - -> ] - ------------------------------------------------------------------------------ -How would we like our code to be generated? - -> optToTarget :: CLIFlags -> Maybe Target -> optToTarget OptArrayTarget = Just TargetArrayBased -> optToTarget _ = Nothing - -Note: we need -cpp at the moment because the template has some -GHC version-dependent stuff in it. - -> langExtsToInject :: [CLIFlags] -> [String] -> langExtsToInject cli -> | OptGhcTarget `elem` cli = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances"] -> | otherwise = [] - -> importsToInject :: [CLIFlags] -> String -> importsToInject cli = -> concat ["\n", import_array, import_bits, -> glaexts_import, debug_imports, applicative_imports] -> where -> glaexts_import | is_ghc = import_glaexts -> | otherwise = "" -> -> debug_imports | is_debug = import_debug -> | otherwise = "" -> -> applicative_imports = import_applicative -> -> is_ghc = OptGhcTarget `elem` cli -> is_debug = OptDebugParser `elem` cli - -CPP is turned on for -fglasgow-exts, so we can use conditional compilation: - -> import_glaexts :: String -> import_glaexts = "import qualified GHC.Exts as Happy_GHC_Exts\n" - -> import_array :: String -> import_array = "import qualified Data.Array as Happy_Data_Array\n" - -> import_bits :: String -> import_bits = "import qualified Data.Bits as Bits\n" - -> import_debug :: String -> import_debug = -> "import qualified System.IO as Happy_System_IO\n" ++ -> "import qualified System.IO.Unsafe as Happy_System_IO_Unsafe\n" ++ -> "import qualified Debug.Trace as Happy_Debug_Trace\n" - -> import_applicative :: String -> import_applicative = "import Control.Applicative(Applicative(..))\n" ++ -> "import Control.Monad (ap)\n" - ------------------------------------------------------------------------------- -Extract various command-line options. - -> getTarget :: [CLIFlags] -> IO Target -> getTarget cli = case [ t | (Just t) <- map optToTarget cli ] of -> (t:ts) | all (==t) ts -> return t -> [] -> return TargetHaskell -> _ -> dieHappy "multiple target options\n" - -> getOutputFileName :: String -> [CLIFlags] -> IO String -> getOutputFileName ip_file cli -> = case [ s | (OptOutputFile s) <- cli ] of -> [] -> return (base ++ ".hs") -> where (base, _ext) = break (== '.') ip_file -> f:fs -> return (last (f:fs)) - -> getInfoFileName :: String -> [CLIFlags] -> IO (Maybe String) -> getInfoFileName base cli -> = case [ s | (OptInfoFile s) <- cli ] of -> [] -> return Nothing -> [f] -> case f of -> Nothing -> return (Just (base ++ ".info")) -> Just j -> return (Just j) -> _many -> dieHappy "multiple --info/-i options\n" - -> getPrettyFileName :: String -> [CLIFlags] -> IO (Maybe String) -> getPrettyFileName base cli -> = case [ s | (OptPrettyFile s) <- cli ] of -> [] -> return Nothing -> [f] -> case f of -> Nothing -> return (Just (base ++ ".grammar")) -> Just j -> return (Just j) -> _many -> dieHappy "multiple --pretty/-p options\n" - -> getTemplate :: IO String -> [CLIFlags] -> IO String -> getTemplate def cli -> = case [ s | (OptTemplate s) <- cli ] of -> [] -> def -> f:fs -> return (last (f:fs)) - -> getMagicName :: [CLIFlags] -> IO (Maybe String) -> getMagicName cli -> = case [ s | (OptMagicName s) <- cli ] of -> [] -> return Nothing -> f:fs -> return (Just (map toLower (last (f:fs)))) - -> getCoerce :: Target -> [CLIFlags] -> IO Bool -> getCoerce _target cli -> = if OptUseCoercions `elem` cli -> then if OptGhcTarget `elem` cli -> then return True -> else dieHappy ("-c/--coerce may only be used " ++ -> "in conjunction with -g/--ghc\n") -> else return False - -> getArray :: [CLIFlags] -> IO Bool -> getArray cli = return (OptArrayTarget `elem` cli) - -> getGhc :: [CLIFlags] -> IO Bool -> getGhc cli = return (OptGhcTarget `elem` cli) - -> getStrict :: [CLIFlags] -> IO Bool -> getStrict cli = return (OptStrict `elem` cli) - ------------------------------------------------------------------------------- - -> copyright :: String -> copyright = unlines [ -> "Happy Version " ++ showVersion version ++ " Copyright (c) 1993-1996 Andy Gill, Simon Marlow (c) 1997-2005 Simon Marlow","", -> "Happy is a Yacc for Haskell, and comes with ABSOLUTELY NO WARRANTY.", -> "This program is free software; you can redistribute it and/or modify", -> "it under the terms given in the file 'LICENSE' distributed with", -> "the Happy sources."] - -> usageHeader :: String -> String -> usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file\n" - ------------------------------------------------------------------------------ diff --git a/src/ParseMonad.hs b/src/ParseMonad.hs deleted file mode 100644 index 634de1bd..00000000 --- a/src/ParseMonad.hs +++ /dev/null @@ -1,8 +0,0 @@ -module ParseMonad (module X) where - --- We use the bootstrapped version if it is available -#ifdef HAPPY_BOOTSTRAP -import ParseMonad.Bootstrapped as X -#else -import ParseMonad.Oracle as X -#endif diff --git a/src/Parser.hs b/src/Parser.hs deleted file mode 100644 index c6269df4..00000000 --- a/src/Parser.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Parser (module X) where - --- We use the bootstrapped version if it is available -#ifdef HAPPY_BOOTSTRAP -import Parser.Bootstrapped as X -#else -import Parser.Oracle as X -#endif diff --git a/test.hs b/test.hs deleted file mode 100644 index 816640d3..00000000 --- a/test.hs +++ /dev/null @@ -1,9 +0,0 @@ -import Data.List (intercalate) -import GHC.Conc (numCapabilities) -import System.Process (system) -import System.Exit (exitWith) - -main = do - let jFlag = "-j" ++ show numCapabilities - let cmd = ["make", jFlag, "-k", "-C", "tests", "clean", "all"] - system (intercalate " " cmd) >>= exitWith diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 index fc7cbf6b..00000000 --- a/tests/Makefile +++ /dev/null @@ -1,137 +0,0 @@ -# NOTE: `cabal test` will take care to build the local `happy` -# executable and place it into $PATH for us to pick up. -# -# If it doesn't look like the alex binary in $PATH comes from the -# build tree, then we'll fall back to pointing to -# ../dist/build/alex/alex to support running tests via "runghc -# Setup.hs test". -# -# If HAPPY has been set outside, e.g. in the environment, we trust this setting. -# This way, we can pass in the correct Happy executable from a CI environment -# without danger of it being "fixed" by the logic below. -# [2021-07-14, PR #196](https://github.com/simonmar/happy/pull/196) -# -ifndef HAPPY -HAPPY=$(shell which happy) -ifeq "$(filter $(dir $(shell pwd))%,$(HAPPY))" "" -HAPPY=../dist/build/happy/happy -endif -endif - -# NOTE: This assumes that a working `ghc` is on $PATH; this may not -# necessarily be the same GHC used by `cabal` for building `happy`. -# -# Again, if HC has been set in the environment (e.g. by the CI), we keep this setting. -# [2021-07-14, PR #196](https://github.com/simonmar/happy/pull/196) -# -HC ?= ghc -HC_OPTS=-Wall -Werror - -.PRECIOUS: %.n.hs %.g.hs %.o %.exe %.bin - -ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" -HS_PROG_EXT = .exe -else -HS_PROG_EXT = .bin -endif - -TESTS = Test.ly TestMulti.ly TestPrecedence.ly bug001.ly \ - monad001.y monad002.ly precedence001.ly precedence002.y \ - bogus-token.y bug002.y Partial.ly \ - issue91.y issue93.y issue94.y issue95.y \ - test_rules.y monaderror.y monaderror-explist.y \ - typeclass_monad001.y typeclass_monad002.ly typeclass_monad_lexer.y \ - rank2.y shift01.y - -ifdef HAPPY_BOOTSTRAP -TESTS += AttrGrammar001.y AttrGrammar002.y -endif - -ERROR_TESTS = error001.y - -# NOTE: `cabal` will set the `happy_datadir` env-var accordingly before invoking the test-suite -#TEST_HAPPY_OPTS = --strict --template=.. -TEST_HAPPY_OPTS = --strict - -%.n.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ - -%.a.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -a $< -o $@ - -%.g.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -g $< -o $@ - -%.gc.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -gc $< -o $@ - -%.ag.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -ag $< -o $@ - -%.agc.hs : %.ly - $(HAPPY) $(TEST_HAPPY_OPTS) -agc $< -o $@ - -%.n.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) $< -o $@ - -%.a.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -a $< -o $@ - -%.g.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -g $< -o $@ - -%.gc.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -gc $< -o $@ - -%.ag.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -ag $< -o $@ - -%.agc.hs : %.y - $(HAPPY) $(TEST_HAPPY_OPTS) -agc $< -o $@ - -CLEAN_FILES += *.n.hs *.a.hs *.g.hs *.gc.hs *.ag.hs *.agc.hs *.info *.hi *.bin *.exe *.o *.run.stdout *.run.stderr - -ALL_TEST_HS = $(shell echo $(TESTS) | sed -e 's/\([^\. ]*\)\.\(l\)\{0,1\}y/\1.n.hs \1.a.hs \1.g.hs \1.gc.hs \1.ag.hs \1.agc.hs/g') - -ALL_TESTS = $(patsubst %.hs, %.run, $(ALL_TEST_HS)) - -CHECK_ERROR_TESTS = $(patsubst %, check.%, $(ERROR_TESTS)) - -HC_OPTS += -fforce-recomp - -.PRECIOUS: %.hs %.o %.bin %.$(HS_PROG_EXT) - -%.run : %$(HS_PROG_EXT) - @echo "--> Checking $<..." - ./$< - -check.%.y : %.y - @echo "--> Checking $<..." - $(HAPPY) $(TEST_HAPPY_OPTS) $< 1>$*.run.stdout 2>$*.run.stderr || true - sed -i '/^Up to date$$/d' $*.run.stdout $*.run.stderr - @diff -u --ignore-all-space $*.stdout $*.run.stdout - @diff -u --ignore-all-space $*.stderr $*.run.stderr - -%$(HS_PROG_EXT) : %.hs - $(HC) $(HC_OPTS) $($*_LD_OPTS) $< -o $@ - -all :: $(CHECK_ERROR_TESTS) $(ALL_TESTS) - -check-todo:: - $(HAPPY) $(TEST_HAPPY_OPTS) -ad Test.ly - $(HC) Test.hs -o happy_test - ./happy_test - -rm -f ./happy_test - $(HAPPY) $(TEST_HAPPY_OPTS) -agd Test.ly - $(HC) Test.hs -o happy_test - ./happy_test - -rm -f ./happy_test - $(HAPPY) $(TEST_HAPPY_OPTS) -agcd Test.ly - $(HC) Test.hs -o happy_test - ./happy_test - -rm -f ./happy_test - -.PHONY: clean - -clean: - $(RM) $(CLEAN_FILES) diff --git a/tests/error001.stderr b/tests/error001.stderr deleted file mode 100644 index 8c5f33fe..00000000 --- a/tests/error001.stderr +++ /dev/null @@ -1,5 +0,0 @@ -error001.y: Multiple rules for 'foo' -error001.y: 8: unknown identifier ''a'' -error001.y: 10: unknown identifier ''a'' -error001.y: 11: unknown identifier ''b'' - diff --git a/tests/error001.stdout b/tests/error001.stdout deleted file mode 100644 index e69de29b..00000000 diff --git a/tests/error001.y b/tests/error001.y deleted file mode 100644 index 83e55fc4..00000000 --- a/tests/error001.y +++ /dev/null @@ -1,10 +0,0 @@ -%name foo -%tokentype { Token } - -%% - -foo : 'a' { } - -bar : 'a' { } - -foo : 'b' { }