diff --git a/.github/workflows/build-all-versions.yml b/.github/workflows/build-all-versions.yml index 46bd05b23..9ab8a0622 100644 --- a/.github/workflows/build-all-versions.yml +++ b/.github/workflows/build-all-versions.yml @@ -14,7 +14,7 @@ jobs: strategy: matrix: os: [ubuntu-latest, macos-latest, windows-latest] - cabal: ["3.2"] + cabal: ["latest"] ghc: - "8.6.5" - "8.8.3" @@ -33,7 +33,7 @@ jobs: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - - uses: actions/setup-haskell@v1.1.4 + - uses: haskell/actions/setup@v1 id: setup-haskell-cabal name: Setup Haskell with: @@ -65,7 +65,7 @@ jobs: runs-on: ubuntu-latest strategy: matrix: - stack: ["2.3.3"] + stack: ["latest"] ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4"] # ghc: ["8.8.3"] @@ -73,11 +73,12 @@ jobs: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - - uses: actions/setup-haskell@v1.1.4 + - uses: haskell/actions/setup@v1 name: Setup Haskell Stack with: - # ghc-version: ${{ matrix.ghc }} - stack-version: ${{ matrix.stack }} + ghc-version: ${{ matrix.ghc }} + stack-version: 'latest' + enable-stack: true - uses: actions/cache@v1 name: Cache ~/.stack @@ -90,6 +91,6 @@ jobs: stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks - # - name: Test - # run: | - # stack test --system-ghc + - name: Test + run: | + stack test --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml diff --git a/.github/workflows/build-binary-packages.yml b/.github/workflows/build-binary-packages.yml index 810fa1352..493d5e774 100644 --- a/.github/workflows/build-binary-packages.yml +++ b/.github/workflows/build-binary-packages.yml @@ -2,7 +2,8 @@ name: Build Binary Packages on: workflow_dispatch: - release: + release: + types: ["created"] jobs: @@ -10,11 +11,13 @@ jobs: ubuntu: name: Build Ubuntu package - runs-on: ubuntu-18.04 - # strategy: - # matrix: - # ghc: ["8.6.5"] - # cabal: ["2.4"] + strategy: + matrix: + os: + - ubuntu-18.04 + - ubuntu-20.04 + + runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 @@ -53,19 +56,33 @@ jobs: - name: Upload artifact uses: actions/upload-artifact@v2 with: - name: gf-${{ github.sha }}-ubuntu + name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb path: dist/gf_*.deb if-no-files-found: error + - name: Rename package for specific ubuntu version + run: | + mv dist/gf_*.deb dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb + + - uses: actions/upload-release-asset@v1.0.2 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ github.event.release.upload_url }} + asset_path: dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb + asset_name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb + asset_content_type: application/octet-stream + # --- macos: name: Build macOS package - runs-on: macos-10.15 strategy: matrix: ghc: ["8.6.5"] cabal: ["2.4"] + os: ["macos-10.15"] + runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 @@ -92,19 +109,33 @@ jobs: - name: Upload artifact uses: actions/upload-artifact@v2 with: - name: gf-${{ github.sha }}-macos + name: gf-${{ github.event.release.tag_name }}-macos path: dist/gf-*.pkg if-no-files-found: error + + - name: Rename package + run: | + mv dist/gf-*.pkg dist/gf-${{ github.event.release.tag_name }}-macos.pkg + + - uses: actions/upload-release-asset@v1.0.2 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ github.event.release.upload_url }} + asset_path: dist/gf-${{ github.event.release.tag_name }}-macos.pkg + asset_name: gf-${{ github.event.release.tag_name }}-macos.pkg + asset_content_type: application/octet-stream # --- windows: name: Build Windows package - runs-on: windows-2019 strategy: matrix: ghc: ["8.6.5"] cabal: ["2.4"] + os: ["windows-2019"] + runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v2 @@ -136,16 +167,18 @@ jobs: cp /mingw64/bin/libpgf-0.dll /c/tmp-dist/c cp /mingw64/bin/libgu-0.dll /c/tmp-dist/c + # JAVA_HOME_8_X64 = C:\hostedtoolcache\windows\Java_Adopt_jdk\8.0.292-10\x64 - name: Build Java bindings shell: msys2 {0} run: | - export PATH="${PATH}:/c/Program Files/Java/jdk8u275-b01/bin" + export JDKPATH=/c/hostedtoolcache/windows/Java_Adopt_jdk/8.0.292-10/x64 + export PATH="${PATH}:${JDKPATH}/bin" cd src/runtime/java make \ - JNI_INCLUDES="-I \"/c/Program Files/Java/jdk8u275-b01/include\" -I \"/c/Program Files/Java/jdk8u275-b01/include/win32\" -I \"/mingw64/include\" -D__int64=int64_t" \ + JNI_INCLUDES="-I \"${JDKPATH}/include\" -I \"${JDKPATH}/include/win32\" -I \"/mingw64/include\" -D__int64=int64_t" \ WINDOWS_LDFLAGS="-L\"/mingw64/lib\" -no-undefined" make install - cp .libs//msys-jpgf-0.dll /c/tmp-dist/java/jpgf.dll + cp .libs/msys-jpgf-0.dll /c/tmp-dist/java/jpgf.dll cp jpgf.jar /c/tmp-dist/java - name: Build Python bindings @@ -157,7 +190,7 @@ jobs: cd src/runtime/python python setup.py build python setup.py install - cp /usr/lib/python3.8/site-packages/pgf* /c/tmp-dist/python + cp /usr/lib/python3.9/site-packages/pgf* /c/tmp-dist/python - name: Setup Haskell uses: actions/setup-haskell@v1 @@ -180,6 +213,18 @@ jobs: - name: Upload artifact uses: actions/upload-artifact@v2 with: - name: gf-${{ github.sha }}-windows + name: gf-${{ github.event.release.tag_name }}-windows path: C:\tmp-dist\* if-no-files-found: error + + - name: Create archive + run: | + Compress-Archive C:\tmp-dist C:\gf-${{ github.event.release.tag_name }}-windows.zip + - uses: actions/upload-release-asset@v1.0.2 + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + with: + upload_url: ${{ github.event.release.upload_url }} + asset_path: C:\gf-${{ github.event.release.tag_name }}-windows.zip + asset_name: gf-${{ github.event.release.tag_name }}-windows.zip + asset_content_type: application/zip diff --git a/.github/workflows/build-python-package.yml b/.github/workflows/build-python-package.yml index 6326821dc..67cbba6dd 100644 --- a/.github/workflows/build-python-package.yml +++ b/.github/workflows/build-python-package.yml @@ -25,7 +25,7 @@ jobs: - name: Install cibuildwheel run: | - python -m pip install git+https://github.com/joerick/cibuildwheel.git@master + python -m pip install git+https://github.com/joerick/cibuildwheel.git@main - name: Install build tools for OSX if: startsWith(matrix.os, 'macos') diff --git a/.gitignore b/.gitignore index 01b58ccb4..b698d53ab 100644 --- a/.gitignore +++ b/.gitignore @@ -53,6 +53,10 @@ DATA_DIR stack*.yaml.lock +# Output files for test suite +*.out +gf-tests.html + # Generated documentation (not exhaustive) demos/index-numbers.html demos/resourcegrammars.html diff --git a/Makefile b/Makefile index 93a8dc20b..cdb35e49a 100644 --- a/Makefile +++ b/Makefile @@ -1,31 +1,48 @@ -.PHONY: all build install doc clean gf html deb pkg bintar sdist +.PHONY: all build install doc clean html deb pkg bintar sdist # This gets the numeric part of the version from the cabal file VERSION=$(shell sed -ne "s/^version: *\([0-9.]*\).*/\1/p" gf.cabal) +# Check if stack is installed +STACK=$(shell if hash stack 2>/dev/null; then echo "1"; else echo "0"; fi) + +# Check if cabal >= 2.4 is installed (with v1- and v2- commands) +CABAL_NEW=$(shell if cabal v1-repl --help >/dev/null 2>&1 ; then echo "1"; else echo "0"; fi) + +ifeq ($(STACK),1) + CMD=stack +else + CMD=cabal + ifeq ($(CABAL_NEW),1) + CMD_PFX=v1- + endif +endif + all: build dist/setup-config: gf.cabal Setup.hs WebSetup.hs - cabal configure +ifneq ($(STACK),1) + cabal ${CMD_PFX}configure +endif build: dist/setup-config - cabal build + ${CMD} ${CMD_PFX}build install: - cabal copy - cabal register +ifeq ($(STACK),1) + stack install +else + cabal ${CMD_PFX}copy + cabal ${CMD_PFX}register +endif doc: - cabal haddock + ${CMD} ${CMD_PFX}haddock clean: - cabal clean + ${CMD} ${CMD_PFX}clean bash bin/clean_html -gf: - cabal build rgl-none - strip dist/build/gf/gf - html:: bash bin/update_html @@ -35,7 +52,7 @@ html:: deb: dpkg-buildpackage -b -uc -# Make an OS X Installer package +# Make a macOS installer package pkg: FMT=pkg bash bin/build-binary-dist.sh diff --git a/README.md b/README.md index 2afa476ea..e393be0e6 100644 --- a/README.md +++ b/README.md @@ -30,13 +30,16 @@ GF particularly addresses four aspects of grammars: ## Compilation and installation -The simplest way of installing GF is with the command: +The simplest way of installing GF from source is with the command: ``` cabal install ``` +or: +``` +stack install +``` -For more details, see the [download page](http://www.grammaticalframework.org/download/index.html) -and [developers manual](http://www.grammaticalframework.org/doc/gf-developers.html). +For more information, including links to precompiled binaries, see the [download page](http://www.grammaticalframework.org/download/index.html). ## About this repository diff --git a/RELEASE.md b/RELEASE.md index 3a771b78d..04bd4b933 100644 --- a/RELEASE.md +++ b/RELEASE.md @@ -45,6 +45,8 @@ but the generated _artifacts_ must be manually attached to the release as _asset ### 4. Upload to Hackage +In order to do this you will need to be added the [GF maintainers](https://hackage.haskell.org/package/gf/maintainers/) on Hackage. + 1. Run `make sdist` 2. Upload the package, either: 1. **Manually**: visit and upload the file `dist/gf-X.Y.tar.gz` diff --git a/debian/changelog b/debian/changelog index d413530a1..e91bf28fb 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +gf (3.11) bionic focal; urgency=low + + * GF 3.11 + + -- Inari Listenmaa Sun, 25 Jul 2021 10:27:40 +0800 + gf (3.10.4-1) xenial bionic cosmic; urgency=low * GF 3.10.4 diff --git a/debian/rules b/debian/rules index 8bd3c1f85..7ec04b4e2 100755 --- a/debian/rules +++ b/debian/rules @@ -16,9 +16,9 @@ override_dh_shlibdeps: override_dh_auto_configure: cd src/runtime/c && bash setup.sh configure --prefix=/usr cd src/runtime/c && bash setup.sh build - cabal update - cabal install --only-dependencies - cabal configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c + cabal v1-update + cabal v1-install --only-dependencies + cabal v1-configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c SET_LDL=LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs @@ -26,10 +26,10 @@ override_dh_auto_build: cd src/runtime/python && EXTRA_INCLUDE_DIRS=$(CURDIR)/src/runtime/c EXTRA_LIB_DIRS=$(CURDIR)/src/runtime/c/.libs python setup.py build cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr echo $(SET_LDL) - -$(SET_LDL) cabal build + -$(SET_LDL) cabal v1-build override_dh_auto_install: - $(SET_LDL) cabal copy --destdir=$(CURDIR)/debian/gf + $(SET_LDL) cabal v1-copy --destdir=$(CURDIR)/debian/gf cd src/runtime/c && bash setup.sh copy prefix=$(CURDIR)/debian/gf/usr cd src/runtime/python && python setup.py install --prefix=$(CURDIR)/debian/gf/usr cd src/runtime/java && make INSTALL_PATH=$(CURDIR)/debian/gf/usr install diff --git a/doc/gf-developers-old-cabal.t2t b/doc/gf-developers-old-cabal.t2t new file mode 100644 index 000000000..0f583bec8 --- /dev/null +++ b/doc/gf-developers-old-cabal.t2t @@ -0,0 +1,201 @@ +GF Developer's Guide: Old installation instructions with Cabal + + +This page contains the old installation instructions from the [Developer's Guide ../doc/gf-developers.html]. +We recommend Stack as a primary installation method, because it's easier for a Haskell beginner, and we want to keep the main instructions short. +But if you are an experienced Haskeller and want to keep using Cabal, here are the old instructions using ``cabal install``. + +Note that some of these instructions may be outdated. Other parts may still be useful. + +== Compilation from source with Cabal == + +The build system of GF is based on //Cabal//, which is part of the +Haskell Platform, so no extra steps are needed to install it. In the simplest +case, all you need to do to compile and install GF, after downloading the +source code as described above, is + +``` +$ cabal install +``` + +This will automatically download any additional Haskell libraries needed to +build GF. If this is the first time you use Cabal, you might need to run +``cabal update`` first, to update the list of available libraries. + +If you want more control, the process can also be split up into the usual +//configure//, //build// and //install// steps. + +=== Configure === + +During the configuration phase Cabal will check that you have all +necessary tools and libraries needed for GF. The configuration is +started by the command: + +``` +$ cabal configure +``` + +If you don't see any error message from the above command then you +have everything that is needed for GF. You can also add the option +``-v`` to see more details about the configuration. + +You can use ``cabal configure --help`` to get a list of configuration options. + +=== Build === + +The build phase does two things. First it builds the GF compiler from +the Haskell source code and after that it builds the GF Resource Grammar +Library using the already build compiler. The simplest command is: + +``` +$ cabal build +``` + +Again you can add the option ``-v`` if you want to see more details. + +==== Parallel builds ==== + +If you have Cabal>=1.20 you can enable parallel compilation by using + +``` +$ cabal build -j +``` + +or by putting a line +``` +jobs: $ncpus +``` +in your ``.cabal/config`` file. Cabal +will pass this option to GHC when building the GF compiler, if you +have GHC>=7.8. + +Cabal also passes ``-j`` to GF to enable parallel compilation of the +Resource Grammar Library. This is done unconditionally to avoid +causing problems for developers with Cabal<1.20. You can disable this +by editing the last few lines in ``WebSetup.hs``. + +=== Install === + +After you have compiled GF you need to install the executable and libraries +to make the system usable. + +``` +$ cabal copy +$ cabal register +``` + +This command installs the GF compiler for a single user, in the standard +place used by Cabal. +On Linux and Mac this could be ``$HOME/.cabal/bin``. +On Mac it could also be ``$HOME/Library/Haskell/bin``. +On Windows this is ``C:\Program Files\Haskell\bin``. + +The compiled GF Resource Grammar Library will be installed +under the same prefix, e.g. in +``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and +in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows. + +If you want to install in some other place then use the ``--prefix`` +option during the configuration phase. + +=== Clean === + +Sometimes you want to clean up the compilation and start again from clean +sources. Use the clean command for this purpose: + +``` +$ cabal clean +``` + + +%=== SDist === +% +%You can use the command: +% +%% This does *NOT* include everything that is needed // TH 2012-08-06 +%``` +%$ cabal sdist +%``` +% +%to prepare archive with all source codes needed to compile GF. + +=== Known problems with Cabal === + +Some versions of Cabal (at least version 1.16) seem to have a bug that can +cause the following error: + +``` +Configuring gf-3.x... +setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed +``` + +The exact cause of this problem is unclear, but it seems to happen +during the configure phase if the same version of GF is already installed, +so a workaround is to remove the existing installation with + +``` +ghc-pkg unregister gf +``` + +You can check with ``ghc-pkg list gf`` that it is gone. + +== Compilation with make == + +If you feel more comfortable with Makefiles then there is a thin Makefile +wrapper arround Cabal for you. If you just type: +``` +$ make +``` +the configuration phase will be run automatically if needed and after that +the sources will be compiled. + +%% cabal build rgl-none does not work with recent versions of Cabal +%If you don't want to compile the resource library +%every time then you can use: +%``` +%$ make gf +%``` + +For installation use: +``` +$ make install +``` +For cleaning: +``` +$ make clean +``` +%and to build source distribution archive run: +%``` +%$ make sdist +%``` + + +== Partial builds of RGL == + +**NOTE**: The following doesn't work with recent versions of ``cabal``. //(This comment was left in 2015, so make your own conclusions.)// +%% // TH 2015-06-22 + +%Sometimes you just want to work on the GF compiler and don't want to +%recompile the resource library after each change. In this case use +%this extended command: + +%``` +%$ cabal build rgl-none +%``` + +The resource grammar library can be compiled in two modes: with present +tense only and with all tenses. By default it is compiled with all +tenses. If you want to use the library with only present tense you can +compile it in this special mode with the command: + +``` +$ cabal build present +``` + +You could also control which languages you want to be recompiled by +adding the option ``langs=list``. For example the following command +will compile only the English and the Swedish language: + +``` +$ cabal build langs=Eng,Swe +``` diff --git a/doc/gf-developers.t2t b/doc/gf-developers.t2t index ed336b9a7..c20afda52 100644 --- a/doc/gf-developers.t2t +++ b/doc/gf-developers.t2t @@ -1,6 +1,6 @@ GF Developers Guide -2018-07-26 +2021-07-15 %!options(html): --toc @@ -15,388 +15,287 @@ you are a GF user who just wants to download and install GF == Setting up your system for building GF == To build GF from source you need to install some tools on your -system: the //Haskell Platform//, //Git// and the //Haskeline library//. +system: the Haskell build tool //Stack//, the version control software //Git// and the //Haskeline// library. -**On Linux** the best option is to install the tools via the standard -software distribution channels, i.e. by using the //Software Center// -in Ubuntu or the corresponding tool in other popular Linux distributions. -Or, from a Terminal window, the following command should be enough: +%**On Linux** the best option is to install the tools via the standard +%software distribution channels, i.e. by using the //Software Center// +%in Ubuntu or the corresponding tool in other popular Linux distributions. -- On Ubuntu: ``sudo apt-get install haskell-platform git libghc6-haskeline-dev`` -- On Fedora: ``sudo dnf install haskell-platform git ghc-haskeline-devel`` +%**On Mac OS and Windows**, the tools can be downloaded from their respective +%web sites, as described below. + +=== Stack === +The primary installation method is via //Stack//. +(You can also use Cabal, but we recommend Stack to those who are new to Haskell.) + +To install Stack: + +- **On Linux and Mac OS**, do either + + ``$ curl -sSL https://get.haskellstack.org/ | sh`` + + or + + ``$ wget -qO- https://get.haskellstack.org/ | sh`` -**On Mac OS and Windows**, the tools can be downloaded from their respective -web sites, as described below. +- **On other operating systems**, see the [installation guide https://docs.haskellstack.org/en/stable/install_and_upgrade]. -=== The Haskell Platform === -GF is written in Haskell, so first of all you need -the //Haskell Platform//, e.g. version 8.0.2 or 7.10.3. Downloads -and installation instructions are available from here: +%If you already have Stack installed, upgrade it to the latest version by running: ``stack upgrade`` - http://hackage.haskell.org/platform/ - -Once you have installed the Haskell Platform, open a terminal -(Command Prompt on Windows) and try to execute the following command: -``` -$ ghc --version -``` -This command should show you which version of GHC you have. If the installation -of the Haskell Platform was successful you should see a message like: - -``` -The Glorious Glasgow Haskell Compilation System, version 8.0.2 -``` - -Other required tools included in the Haskell Platform are -[Cabal http://www.haskell.org/cabal/], -[Alex http://www.haskell.org/alex/] -and -[Happy http://www.haskell.org/happy/]. === Git === -To get the GF source code, you also need //Git//. -//Git// is a distributed version control system, see -https://git-scm.com/downloads for more information. +To get the GF source code, you also need //Git//, a distributed version control system. -=== The haskeline library === +- **On Linux**, the best option is to install the tools via the standard +software distribution channels: + + - On Ubuntu: ``sudo apt-get install git-all`` + - On Fedora: ``sudo dnf install git-all`` + + +- **On other operating systems**, see +https://git-scm.com/book/en/v2/Getting-Started-Installing-Git for installation. + + + +=== Haskeline === GF uses //haskeline// to enable command line editing in the GF shell. -This should work automatically on Mac OS and Windows, but on Linux one -extra step is needed to make sure the C libraries (terminfo) -required by //haskeline// are installed. Here is one way to do this: -- On Ubuntu: ``sudo apt-get install libghc-haskeline-dev`` -- On Fedora: ``sudo dnf install ghc-haskeline-devel`` +- **On Mac OS and Windows**, this should work automatically. + +- **On Linux**, an extra step is needed to make sure the C libraries (terminfo) +required by //haskeline// are installed: + + - On Ubuntu: ``sudo apt-get install libghc-haskeline-dev`` + - On Fedora: ``sudo dnf install ghc-haskeline-devel`` -== Getting the source == +== Getting the source ==[getting-source] -Once you have all tools in place you can get the GF source code. If you -just want to compile and use GF then it is enough to have read-only -access. It is also possible to make changes in the source code but if you -want these changes to be applied back to the main source repository you will -have to send the changes to us. If you plan to work continuously on -GF then you should consider getting read-write access. +Once you have all tools in place you can get the GF source code from +[GitHub https://github.com/GrammaticalFramework/]: -=== Read-only access === +- https://github.com/GrammaticalFramework/gf-core for the GF compiler +- https://github.com/GrammaticalFramework/gf-rgl for the Resource Grammar Library -==== Getting a fresh copy for read-only access ==== -Anyone can get the latest development version of GF by running: +=== Read-only access: clone the main repository === + +If you only want to compile and use GF, you can just clone the repositories as follows: ``` -$ git clone https://github.com/GrammaticalFramework/gf-core.git -$ git clone https://github.com/GrammaticalFramework/gf-rgl.git + $ git clone https://github.com/GrammaticalFramework/gf-core.git + $ git clone https://github.com/GrammaticalFramework/gf-rgl.git ``` -This will create directories ``gf-core`` and ``gf-rgl`` in the current directory. - - -==== Updating your copy ==== - -To get all new patches from each repo: -``` -$ git pull -``` -This can be done anywhere in your local repository. - - -==== Recording local changes ====[record] - -Since every copy is a repository, you can have local version control -of your changes. - -If you have added files, you first need to tell your local repository to -keep them under revision control: +To get new updates, run the following anywhere in your local copy of the repository: ``` -$ git add file1 file2 ... + $ git pull ``` -To record changes, use: +=== Contribute your changes: fork the main repository === + +If you want the possibility to contribute your changes, +you should create your own fork, do your changes there, +and then send a pull request to the main repository. + ++ **Creating and cloning a fork —** +See GitHub documentation for instructions how to [create your own fork https://docs.github.com/en/get-started/quickstart/fork-a-repo] +of the repository. Once you've done it, clone the fork to your local computer. ``` -$ git commit file1 file2 ... + $ git clone https://github.com//gf-core.git ``` -This creates a patch against the previous version and stores it in your -local repository. You can record any number of changes before -pushing them to the main repo. In fact, you don't have to push them at -all if you want to keep the changes only in your local repo. - -Instead of enumerating all modified files on the command line, -you can use the flag ``-a`` to automatically record //all// modified -files. You still need to use ``git add`` to add new files. - - -=== Read-write access === - -If you are a member of the GF project on GitHub, you can push your -changes directly to the GF git repository on GitHub. ++ **Updating your copy —** +Once you have cloned your fork, you need to set up the main repository as a remote: ``` -$ git push + $ git remote add upstream https://github.com/GrammaticalFramework/gf-core.git ``` -It is also possible for anyone else to contribute by +Then you can get the latest updates by running the following: -- creating a fork of the GF repository on GitHub, -- working with local clone of the fork (obtained with ``git clone``), -- pushing changes to the fork, -- and finally sending a pull request. +``` + $ git pull upstream master +``` + ++ **Recording local changes —** +See Git tutorial on how to [record and push your changes https://git-scm.com/book/en/v2/Git-Basics-Recording-Changes-to-the-Repository] to your fork. + ++ **Pull request —** +When you want to contribute your changes to the main gf-core repository, +[create a pull request https://docs.github.com/en/github/collaborating-with-pull-requests/proposing-changes-to-your-work-with-pull-requests/creating-a-pull-request] +from your fork. -== Compilation from source with Cabal == +If you want to contribute to the RGL as well, do the same process for the RGL repository. -The build system of GF is based on //Cabal//, which is part of the -Haskell Platform, so no extra steps are needed to install it. In the simplest -case, all you need to do to compile and install GF, after downloading the -source code as described above, is + +== Compilation from source == + +By now you should have installed Stack and Haskeline, and cloned the Git repository on your own computer, in a directory called ``gf-core``. + +=== Primary recommendation: use Stack === + +Open a terminal, go to the top directory (``gf-core``), and type the following command. + +``` +$ stack install +``` + +It will install GF and all necessary tools and libraries to do that. + + +=== Alternative: use Cabal === +You can also install GF using Cabal, if you prefer Cabal to Stack. In that case, you may need to install some prerequisites yourself. + +The actual installation process is similar to Stack: open a terminal, go to the top directory (``gf-core``), and type the following command. ``` $ cabal install ``` -This will automatically download any additional Haskell libraries needed to -build GF. If this is the first time you use Cabal, you might need to run -``cabal update`` first, to update the list of available libraries. +//The old (potentially outdated) instructions for Cabal are moved to a [separate page ../doc/gf-developers-old-cabal.html]. If you run into trouble with ``cabal install``, you may want to take a look.// -If you want more control, the process can also be split up into the usual -//configure//, //build// and //install// steps. +== Compiling GF with C runtime system support == -=== Configure === - -During the configuration phase Cabal will check that you have all -necessary tools and libraries needed for GF. The configuration is -started by the command: - -``` -$ cabal configure -``` - -If you don't see any error message from the above command then you -have everything that is needed for GF. You can also add the option -``-v`` to see more details about the configuration. - -You can use ``cabal configure --help`` to get a list of configuration options. - -=== Build === - -The build phase does two things. First it builds the GF compiler from -the Haskell source code and after that it builds the GF Resource Grammar -Library using the already build compiler. The simplest command is: - -``` -$ cabal build -``` - -Again you can add the option ``-v`` if you want to see more details. - -==== Parallel builds ==== - -If you have Cabal>=1.20 you can enable parallel compilation by using - -``` -$ cabal build -j -``` - -or by putting a line -``` -jobs: $ncpus -``` -in your ``.cabal/config`` file. Cabal -will pass this option to GHC when building the GF compiler, if you -have GHC>=7.8. - -Cabal also passes ``-j`` to GF to enable parallel compilation of the -Resource Grammar Library. This is done unconditionally to avoid -causing problems for developers with Cabal<1.20. You can disable this -by editing the last few lines in ``WebSetup.hs``. - - -==== Partial builds ==== - -**NOTE**: The following doesn't work with recent versions of ``cabal``. -%% // TH 2015-06-22 - -Sometimes you just want to work on the GF compiler and don't want to -recompile the resource library after each change. In this case use -this extended command: - -``` -$ cabal build rgl-none -``` - -The resource library could also be compiled in two modes: with present -tense only and with all tenses. By default it is compiled with all -tenses. If you want to use the library with only present tense you can -compile it in this special mode with the command: - -``` -$ cabal build present -``` - -You could also control which languages you want to be recompiled by -adding the option ``langs=list``. For example the following command -will compile only the English and the Swedish language: - -``` -$ cabal build langs=Eng,Swe -``` - -=== Install === - -After you have compiled GF you need to install the executable and libraries -to make the system usable. - -``` -$ cabal copy -$ cabal register -``` - -This command installs the GF compiler for a single user, in the standard -place used by Cabal. -On Linux and Mac this could be ``$HOME/.cabal/bin``. -On Mac it could also be ``$HOME/Library/Haskell/bin``. -On Windows this is ``C:\Program Files\Haskell\bin``. - -The compiled GF Resource Grammar Library will be installed -under the same prefix, e.g. in -``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and -in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows. - -If you want to install in some other place then use the ``--prefix`` -option during the configuration phase. - -=== Clean === - -Sometimes you want to clean up the compilation and start again from clean -sources. Use the clean command for this purpose: - -``` -$ cabal clean -``` - - -%=== SDist === -% -%You can use the command: -% -%% This does *NOT* include everything that is needed // TH 2012-08-06 -%``` -%$ cabal sdist -%``` -% -%to prepare archive with all source codes needed to compile GF. - -=== Known problems with Cabal === - -Some versions of Cabal (at least version 1.16) seem to have a bug that can -cause the following error: - -``` -Configuring gf-3.x... -setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed -``` - -The exact cause of this problem is unclear, but it seems to happen -during the configure phase if the same version of GF is already installed, -so a workaround is to remove the existing installation with - -``` -ghc-pkg unregister gf -``` - -You can check with ``ghc-pkg list gf`` that it is gone. - -== Compilation with make == - -If you feel more comfortable with Makefiles then there is a thin Makefile -wrapper arround Cabal for you. If you just type: -``` -$ make -``` -the configuration phase will be run automatically if needed and after that -the sources will be compiled. - -%% cabal build rgl-none does not work with recent versions of Cabal -%If you don't want to compile the resource library -%every time then you can use: -%``` -%$ make gf -%``` - -For installation use: -``` -$ make install -``` -For cleaning: -``` -$ make clean -``` -%and to build source distribution archive run: -%``` -%$ make sdist -%``` - -== Compiling GF with C run-time system support == - -The C run-time system is a separate implementation of the PGF run-time services. +The C runtime system is a separate implementation of the PGF runtime services. It makes it possible to work with very large, ambiguous grammars, using -probabilistic models to obtain probable parses. The C run-time system might -also be easier to use than the Haskell run-time system on certain platforms, +probabilistic models to obtain probable parses. The C runtime system might +also be easier to use than the Haskell runtime system on certain platforms, e.g. Android and iOS. -To install the C run-time system, go to the ``src/runtime/c`` directory -%and follow the instructions in the ``INSTALL`` file. -and use the ``install.sh`` script: -``` -bash setup.sh configure -bash setup.sh build -bash setup.sh install -``` -This will install -the C header files and libraries need to write C programs that use PGF grammars. -Some example C programs are included in the ``utils`` subdirectory, e.g. -``pgf-translate.c``. +To install the C runtime system, go to the ``src/runtime/c`` directory. -When the C run-time system is installed, you can install GF with C run-time -support by doing +- **On Linux and Mac OS —** + You should have autoconf, automake, libtool and make. + If you are missing some of them, follow the + instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file. + + Once you have the required libraries, the easiest way to install the C runtime is to use the ``install.sh`` script. Just type + + ``$ bash install.sh`` + + This will install the C header files and libraries need to write C programs + that use PGF grammars. + +% If this doesn't work for you, follow the manual instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system. + +- **On other operating systems —** Follow the instructions in the +[INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system. + + + +Depending on what you want to do with the C runtime, you can follow one or more of the following steps. + +=== Use the C runtime from another programming language ===[bindings] + +% **If you just want to use the C runtime from Python, Java, or Haskell, you don't need to change your GF installation.** + +- **What —** +This is the most common use case for the C runtime: compile +your GF grammars into PGF with the standard GF executable, +and manipulate the PGFs from another programming language, +using the bindings to the C runtime. + + +- **How —** +The Python, Java and Haskell bindings are found in the +``src/runtime/{python,java,haskell-bind}`` directories, +respecively. Compile them by following the instructions +in the ``INSTALL`` or ``README`` files in those directories. + +The Python library can also be installed from PyPI using ``pip install pgf``. + + +//If you are on Mac and get an error about ``clang`` version, you can try some of [these solutions https://stackoverflow.com/questions/63972113/big-sur-clang-invalid-version-error-due-to-macosx-deployment-target]—but be careful before removing any existing installations.// + + +=== Use GF shell with C runtime support === + +- **What —** +If you want to use the GF shell with C runtime functionalities, then you need to (re)compile GF with special flags. + +The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use +the C run-time system instead of the Haskell run-time system. +Only limited functionality is available when running the shell in these +modes (use the ``help`` command in the shell for details). + +(Re)compiling your GF with these flags will also give you +Haskell bindings to the C runtime, as a library called ``PGF2``, +but if you want Python or Java bindings, you need to do [the previous step #bindings]. + +% ``PGF2``: a module to import in Haskell programs, providing a binding to the C run-time system. + +- **How —** +If you use cabal, run the following command: ``` -cabal install -fserver -fc-runtime +cabal install -fc-runtime ``` -from the top directory. This give you three new things: -- ``PGF2``: a module to import in Haskell programs, providing a binding to - the C run-time system. +from the top directory (``gf-core``). -- The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use - the C run-time system instead of the Haskell run-time system. - Only limited functionality is available when running the shell in these - modes (use the ``help`` command in the shell for details). +If you use stack, uncomment the following lines in the ``stack.yaml`` file: -- ``gf -server`` mode is extended with new requests to call the C run-time - system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``. +``` +flags: + gf: + c-runtime: true +extra-lib-dirs: + - /usr/local/lib +``` +and then run ``stack install`` from the top directory (``gf-core``). -=== Python and Java bindings === +//If you get an "``error while loading shared libraries``" when trying to run GF with C runtime, remember to declare your ``LD_LIBRARY_PATH``.// +//Add ``export LD_LIBRARY_PATH="/usr/local/lib"`` to either your ``.bashrc`` or ``.profile``. You should now be able to start GF with C runtime.// + + +=== Use GF server mode with C runtime === + +- **What —** +With this feature, ``gf -server`` mode is extended with new requests to call the C run-time +system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``. + +- **How —** +If you use cabal, run the following command: + +``` +cabal install -fc-runtime -fserver +``` +from the top directory. + +If you use stack, add the following lines in the ``stack.yaml`` file: + +``` +flags: + gf: + c-runtime: true + server: true +extra-lib-dirs: + - /usr/local/lib +``` + +and then run ``stack install``, also from the top directory. -The C run-time system can also be used from Python and Java. Python and Java -bindings are found in the ``src/runtime/python`` and ``src/runtime/java`` -directories, respecively. Compile them by following the instructions in -the ``INSTALL`` files in those directories. -The Python library can also be installed from PyPI using `pip install pgf`. == Compilation of RGL == As of 2018-07-26, the RGL is distributed separately from the GF compiler and runtimes. +To get the source, follow the previous instructions on [how to clone a repository with Git #getting-source]. + +After cloning the RGL, you should have a directory named ``gf-rgl`` on your computer. + === Simple === To install the RGL, you can use the following commands from within the ``gf-rgl`` repository: ``` @@ -418,103 +317,68 @@ If you do not have Haskell installed, you can use the simple build script ``Setu == Creating binary distribution packages == -=== Creating .deb packages for Ubuntu === +The binaries are generated with Github Actions. More details can be viewed here: -This was tested on Ubuntu 14.04 for the release of GF 3.6, and the -resulting ``.deb`` packages appears to work on Ubuntu 12.04, 13.10 and 14.04. -For the release of GF 3.7, we generated ``.deb`` packages on Ubuntu 15.04 and -tested them on Ubuntu 12.04 and 14.04. +https://github.com/GrammaticalFramework/gf-core/actions/workflows/build-binary-packages.yml -Under Ubuntu, Haskell executables are statically linked against other Haskell -libraries, so the .deb packages are fairly self-contained. -==== Preparations ==== +== Running the test suite == + +The GF test suite is run with one of the following commands from the top directory: ``` -sudo apt-get install dpkg-dev debhelper + $ cabal test ``` -==== Creating the package ==== - -Make sure the ``debian/changelog`` starts with an entry that describes the -version you are building. Then run +or ``` -make deb + $ stack test ``` -If get error messages about missing dependencies -(e.g. ``autoconf``, ``automake``, ``libtool-bin``, ``python-dev``, -``java-sdk``, ``txt2tags``) -use ``apt-get intall`` to install them, then try again. - - -=== Creating OS X Installer packages === - -Run - -``` -make pkg -``` - -=== Creating binary tar distributions === - -Run - -``` -make bintar -``` - -=== Creating .rpm packages for Fedora === - -This is possible, but the procedure has not been automated. -It involves using the cabal-rpm tool, - -``` -sudo dnf install cabal-rpm -``` - -and following the Fedora guide -[How to create an RPM package http://fedoraproject.org/wiki/How_to_create_an_RPM_package]. - -Under Fedora, Haskell executables are dynamically linked against other Haskell -libraries, so ``.rpm`` packages for all Haskell libraries that GF depends on -are required. Most of them are already available in the Fedora distribution, -but a few of them might have to be built and distributed along with -the GF ``.rpm`` package. -When building ``.rpm`` packages for GF 3.4, we also had to build ``.rpm``s for -``fst`` and ``httpd-shed``. - -== Running the testsuite == - -**NOTE:** The test suite has not been maintained recently, so expect many -tests to fail. -%% // TH 2012-08-06 - -GF has testsuite. It is run with the following command: -``` -$ cabal test -``` The testsuite architecture for GF is very simple but still very flexible. GF by itself is an interpreter and could execute commands in batch mode. This is everything that we need to organize a testsuite. The root of the -testsuite is the testsuite/ directory. It contains subdirectories which -themself contain GF batch files (with extension .gfs). The above command -searches the subdirectories of the testsuite/ directory for files with extension -.gfs and when it finds one it is executed with the GF interpreter. -The output of the script is stored in file with extension .out and is compared -with the content of the corresponding file with extension .gold, if there is one. -If the contents are identical the command reports that the test was passed successfully. -Otherwise the test had failed. +testsuite is the ``testsuite/`` directory. It contains subdirectories +which themselves contain GF batch files (with extension ``.gfs``). +The above command searches the subdirectories of the ``testsuite/`` directory +for files with extension ``.gfs`` and when it finds one, it is executed with +the GF interpreter. The output of the script is stored in file with extension ``.out`` +and is compared with the content of the corresponding file with extension ``.gold``, if there is one. -Every time when you make some changes to GF that have to be tested, instead of -writing the commands by hand in the GF shell, add them to one .gfs file in the testsuite -and run the test. In this way you can use the same test later and we will be sure -that we will not incidentaly break your code later. +Every time when you make some changes to GF that have to be tested, +instead of writing the commands by hand in the GF shell, add them to one ``.gfs`` +file in the testsuite subdirectory where its ``.gf`` file resides and run the test. +In this way you can use the same test later and we will be sure that we will not +accidentally break your code later. + +**Test Outcome - Passed:** If the contents of the files with the ``.out`` extension +are identical to their correspondingly-named files with the extension ``.gold``, +the command will report that the tests passed successfully, e.g. -If you don't want to run the whole testsuite you can write the path to the subdirectory -in which you are interested. For example: ``` -$ cabal test testsuite/compiler + Running 1 test suites... + Test suite gf-tests: RUNNING... + Test suite gf-tests: PASS + 1 of 1 test suites (1 of 1 test cases) passed. ``` -will run only the testsuite for the compiler. + +**Test Outcome - Failed:** If there is a contents mismatch between the files +with the ``.out`` extension and their corresponding files with the extension ``.gold``, +the test diagnostics will show a fail and the areas that failed. e.g. + +``` + testsuite/compiler/compute/Records.gfs: OK + testsuite/compiler/compute/Variants.gfs: FAIL + testsuite/compiler/params/params.gfs: OK + Test suite gf-tests: FAIL + 0 of 1 test suites (0 of 1 test cases) passed. +``` + +The fail results overview is available in gf-tests.html which shows 4 columns: + ++ __Results__ - only areas that fail will appear. (Note: There are 3 failures in the gf-tests.html which are labelled as (expected). These failures should be ignored.) ++ __Input__ - which is the test written in the .gfs file ++ __Gold__ - the expected output from running the test set out in the .gfs file. This column refers to the contents from the .gold extension files. ++ __Output__ - This column refers to the contents from the .out extension files which are generated as test output. +After fixing the areas which fail, rerun the test command. Repeat the entire process of fix-and-test until the test suite passes before submitting a pull request to include your changes. diff --git a/doc/gf-editor-modes.t2t b/doc/gf-editor-modes.t2t index ffa6473ea..4c4a62ab6 100644 --- a/doc/gf-editor-modes.t2t +++ b/doc/gf-editor-modes.t2t @@ -15,6 +15,12 @@ instructions inside. ==Atom== [language-gf https://atom.io/packages/language-gf], by John J. Camilleri +==Visual Studio Code== + +[Grammatical Framework Language Server https://marketplace.visualstudio.com/items?itemName=anka-213.gf-vscode] by Andreas Källberg. + +This provides syntax highlighting and a client for the Grammatical Framework language server. Follow the installation instructions in the link. + ==Eclipse== [GF Eclipse Plugin https://github.com/GrammaticalFramework/gf-eclipse-plugin/], by John J. Camilleri diff --git a/download/index-3.11.md b/download/index-3.11.md index c128e77ce..4f2798a0a 100644 --- a/download/index-3.11.md +++ b/download/index-3.11.md @@ -1,8 +1,9 @@ --- title: Grammatical Framework Download and Installation -... +date: 25 July 2021 +--- -**GF 3.11** was released on ... December 2020. +**GF 3.11** was released on 25 July 2021. What's new? See the [release notes](release-3.11.html). @@ -24,22 +25,25 @@ Binary packages are available for Debian/Ubuntu, macOS, and Windows and include: Unlike in previous versions, the binaries **do not** include the RGL. -[Binary packages on GitHub](https://github.com/GrammaticalFramework/gf-core/releases/tag/RELEASE-3.11) +[Binary packages on GitHub](https://github.com/GrammaticalFramework/gf-core/releases/tag/3.11) #### Debian/Ubuntu +There are two versions: `gf-3.11-ubuntu-18.04.deb` for Ubuntu 18.04 (Cosmic), and `gf-3.11-ubuntu-20.04.deb` for Ubuntu 20.04 (Focal). + To install the package use: + ``` -sudo dpkg -i gf_3.11.deb +sudo apt-get install ./gf-3.11-ubuntu-*.deb ``` -The Ubuntu `.deb` packages should work on Ubuntu 16.04, 18.04 and similar Linux distributions. + #### macOS To install the package, just double-click it and follow the installer instructions. -The packages should work on at least 10.13 (High Sierra) and 10.14 (Mojave). +The packages should work on at least Catalina and Big Sur. #### Windows @@ -49,15 +53,17 @@ You will probably need to update the `PATH` environment variable to include your For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10). -## Installing the latest release from source + ## Installing from the latest developer source code If you haven't already, clone the repository with: @@ -125,7 +120,7 @@ or, if you're a Stack user: stack install ``` -The above notes for installing from source apply also in these cases. + For more info on working with the GF source code, see the [GF Developers Guide](../doc/gf-developers.html). diff --git a/download/index.html b/download/index.html index eb32412f8..810537bd8 100644 --- a/download/index.html +++ b/download/index.html @@ -1,8 +1,8 @@ - + - You are being redirected to the current version of this page. + You are being redirected to the current version of this page. diff --git a/download/release-3.11.md b/download/release-3.11.md index 3cb448303..66d0c6ce1 100644 --- a/download/release-3.11.md +++ b/download/release-3.11.md @@ -1,7 +1,7 @@ --- title: GF 3.11 Release Notes -date: ... December 2020 -... +date: 25 July 2021 +--- ## Installation @@ -12,24 +12,27 @@ See the [download page](index-3.11.html). From this release, the binary GF core packages do not contain the RGL. The RGL's release cycle is now completely separate from GF's. See [RGL releases](https://github.com/GrammaticalFramework/gf-rgl/releases). -Over 400 changes have been pushed to GF core +Over 500 changes have been pushed to GF core since the release of GF 3.10 in December 2018. ## General - Make the test suite work again. - Compatibility with new versions of GHC, including multiple Stack files for the different versions. -- Updates to build scripts and CI. -- Bug fixes. +- Support for newer version of Ubuntu 20.04 in the precompiled binaries. +- Updates to build scripts and CI workflows. +- Bug fixes and code cleanup. ## GF compiler and run-time library -- Huge improvements in time & space requirements for grammar compilation (pending [#87](https://github.com/GrammaticalFramework/gf-core/pull/87)). - Add CoNLL output to `visualize_tree` shell command. - Add canonical GF as output format in the compiler. - Add PGF JSON as output format in the compiler. - Deprecate JavaScript runtime in favour of updated [TypeScript runtime](https://github.com/GrammaticalFramework/gf-typescript). +- Improvements in time & space requirements when compiling certain grammars. - Improvements to Haskell export. +- Improvements to the GF shell. +- Improvements to canonical GF compilation. - Improvements to the C runtime. - Improvements to `gf -server` mode. - Clearer compiler error messages. diff --git a/gf.cabal b/gf.cabal index 0076e7638..711acaeb2 100644 --- a/gf.cabal +++ b/gf.cabal @@ -1,19 +1,19 @@ name: gf -version: 3.10.4-git +version: 3.11.0-git -cabal-version: >= 1.22 +cabal-version: 1.22 build-type: Custom license: OtherLicense license-file: LICENSE category: Natural Language Processing, Compiler synopsis: Grammatical Framework description: GF, Grammatical Framework, is a programming language for multilingual grammar applications -homepage: http://www.grammaticalframework.org/ +homepage: https://www.grammaticalframework.org/ bug-reports: https://github.com/GrammaticalFramework/gf-core/issues -maintainer: Thomas Hallgren -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 data-dir: src +extra-source-files: WebSetup.hs data-files: www/*.html www/*.css @@ -41,23 +41,23 @@ data-files: custom-setup setup-depends: - base, - Cabal >=1.22.0.0, - directory, - filepath, - process >=1.0.1.1 + base >= 4.9.1 && < 4.15, + Cabal >= 1.22.0.0, + directory >= 1.3.0 && < 1.4, + filepath >= 1.4.1 && < 1.5, + process >= 1.0.1.1 && < 1.7 source-repository head - type: git + type: git location: https://github.com/GrammaticalFramework/gf-core.git flag interrupt Description: Enable Ctrl+Break in the shell - Default: True + Default: True flag server Description: Include --server mode - Default: True + Default: True flag network-uri description: Get Network.URI from the network-uri package @@ -69,24 +69,29 @@ flag network-uri flag c-runtime Description: Include functionality from the C run-time library (which must be installed already) - Default: False + Default: False + +library + default-language: Haskell2010 + build-depends: + -- GHC 8.0.2 to GHC 8.10.4 + array >= 0.5.1 && < 0.6, + base >= 4.9.1 && < 4.15, + bytestring >= 0.10.8 && < 0.11, + containers >= 0.5.7 && < 0.7, + exceptions >= 0.8.3 && < 0.11, + ghc-prim >= 0.5.0 && < 0.7, + mtl >= 2.2.1 && < 2.3, + pretty >= 1.1.3 && < 1.2, + random >= 1.1 && < 1.3, + utf8-string >= 1.0.1.1 && < 1.1, + -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant. + transformers-compat >= 0.5.1.4 && < 0.7 + + if impl(ghc<8.0) + build-depends: + fail >= 4.9.0 && < 4.10 -Library - default-language: Haskell2010 - build-depends: base >= 4.6 && <5, - array, - containers, - bytestring, - utf8-string, - random, - pretty, - mtl, - exceptions, - fail, - -- For compatability with ghc < 8 - -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant. - transformers-compat, - ghc-prim hs-source-dirs: src/runtime/haskell other-modules: @@ -135,18 +140,28 @@ Library if flag(c-runtime) exposed-modules: PGF2 - other-modules: PGF2.FFI PGF2.Expr PGF2.Type - GF.Interactive2 GF.Command.Commands2 - hs-source-dirs: src/runtime/haskell-bind - build-tools: hsc2hs + other-modules: + PGF2.FFI + PGF2.Expr + PGF2.Type + GF.Interactive2 + GF.Command.Commands2 + hs-source-dirs: src/runtime/haskell-bind + build-tools: hsc2hs extra-libraries: pgf gu - c-sources: src/runtime/haskell-bind/utils.c - cc-options: -std=c99 + c-sources: src/runtime/haskell-bind/utils.c + cc-options: -std=c99 ---- GF compiler as a library: - build-depends: filepath, directory>=1.2, time, - process, haskeline, parallel>=3, json + build-depends: + directory >= 1.3.0 && < 1.4, + filepath >= 1.4.1 && < 1.5, + haskeline >= 0.7.3 && < 0.9, + json >= 0.9.1 && < 0.11, + parallel >= 3.2.1.1 && < 3.3, + process >= 1.4.3 && < 1.7, + time >= 1.6.0 && < 1.10 hs-source-dirs: src/compiler exposed-modules: @@ -157,12 +172,19 @@ Library GF.Grammar.Canonical other-modules: - GF.Main GF.Compiler GF.Interactive + GF.Main + GF.Compiler + GF.Interactive - GF.Compile GF.CompileInParallel GF.CompileOne GF.Compile.GetGrammar + GF.Compile + GF.CompileInParallel + GF.CompileOne + GF.Compile.GetGrammar GF.Grammar - GF.Data.Operations GF.Infra.Option GF.Infra.UseIO + GF.Data.Operations + GF.Infra.Option + GF.Infra.UseIO GF.Command.Abstract GF.Command.CommandInfo @@ -177,7 +199,7 @@ Library GF.Command.TreeOperations GF.Compile.CFGtoPGF GF.Compile.CheckGrammar - GF.Compile.Compute.ConcreteNew + GF.Compile.Compute.Concrete GF.Compile.Compute.Predef GF.Compile.Compute.Value GF.Compile.ExampleBased @@ -206,7 +228,6 @@ Library GF.Compile.TypeCheck.Concrete GF.Compile.TypeCheck.ConcreteNew GF.Compile.TypeCheck.Primitives - GF.Compile.TypeCheck.RConcrete GF.Compile.TypeCheck.TC GF.Compile.Update GF.Data.BacktrackM @@ -273,12 +294,17 @@ Library cpp-options: -DC_RUNTIME if flag(server) - build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7, - cgi>=3001.2.2.0 + build-depends: + cgi >= 3001.3.0.2 && < 3001.6, + httpd-shed >= 0.4.0 && < 0.5, + network>=2.3 && <2.7 if flag(network-uri) - build-depends: network-uri>=2.6, network>=2.6 + build-depends: + network-uri >= 2.6.1.0 && < 2.7, + network>=2.6 && <2.7 else - build-depends: network<2.6 + build-depends: + network >= 2.5 && <2.6 cpp-options: -DSERVER_MODE other-modules: @@ -295,7 +321,10 @@ Library Fold ExampleDemo ExampleService - hs-source-dirs: src/server src/server/transfer src/example-based + hs-source-dirs: + src/server + src/server/transfer + src/example-based if flag(interrupt) cpp-options: -DUSE_INTERRUPT @@ -304,26 +333,35 @@ Library other-modules: GF.System.NoSignal if impl(ghc>=7.8) - build-tools: happy>=1.19, alex>=3.1 + build-tools: + happy>=1.19, + alex>=3.1 -- ghc-options: +RTS -A20M -RTS else - build-tools: happy, alex>=3 + build-tools: + happy, + alex>=3 ghc-options: -fno-warn-tabs if os(windows) - build-depends: Win32 + build-depends: + Win32 >= 2.3.1.1 && < 2.7 else - build-depends: unix, terminfo>=0.4 + build-depends: + terminfo >=0.4.0 && < 0.5, + unix >= 2.7.2 && < 2.8 if impl(ghc>=8.2) ghc-options: -fhide-source-paths -Executable gf +executable gf hs-source-dirs: src/programs main-is: gf-main.hs - default-language: Haskell2010 - build-depends: gf, base + default-language: Haskell2010 + build-depends: + gf, + base ghc-options: -threaded --ghc-options: -fwarn-unused-imports @@ -337,19 +375,30 @@ Executable gf if impl(ghc>=8.2) ghc-options: -fhide-source-paths -executable pgf-shell ---if !flag(c-runtime) - buildable: False - main-is: pgf-shell.hs - hs-source-dirs: src/runtime/haskell-bind/examples - build-depends: gf, base, containers, mtl, lifted-base - default-language: Haskell2010 - if impl(ghc>=7.0) - ghc-options: -rtsopts +-- executable pgf-shell +-- --if !flag(c-runtime) +-- buildable: False +-- main-is: pgf-shell.hs +-- hs-source-dirs: src/runtime/haskell-bind/examples +-- build-depends: +-- gf, +-- base, +-- containers, +-- mtl, +-- lifted-base +-- default-language: Haskell2010 +-- if impl(ghc>=7.0) +-- ghc-options: -rtsopts test-suite gf-tests - type: exitcode-stdio-1.0 - main-is: run.hs + type: exitcode-stdio-1.0 + main-is: run.hs hs-source-dirs: testsuite - build-depends: base>=4.3 && <5, Cabal>=1.8, directory, filepath, process - default-language: Haskell2010 + build-depends: + base >= 4.9.1 && < 4.15, + Cabal >= 1.8, + directory >= 1.3.0 && < 1.4, + filepath >= 1.4.1 && < 1.5, + process >= 1.4.3 && < 1.7 + build-tool-depends: gf:gf + default-language: Haskell2010 diff --git a/index.html b/index.html index c8a990fd6..8816cc265 100644 --- a/index.html +++ b/index.html @@ -214,9 +214,9 @@ least one, it may help you to get a first idea of what GF is.

- We run the IRC channel #gf on the Freenode network, where you are welcome to look for help with small questions or just start a general discussion. - You can open a web chat - or browse the channel logs. + We run the IRC channel #gf on the Libera network, where you are welcome to look for help with small questions or just start a general discussion. + You can open a web chat + or browse the channel logs.

If you have a larger question which the community may benefit from, we recommend you ask it on the mailing list. @@ -226,7 +226,11 @@ least one, it may help you to get a first idea of what GF is.

News

- +
2021-07-25
+
+ GF 3.11 released. + Release notes +
2021-05-05
@@ -234,7 +238,7 @@ least one, it may help you to get a first idea of what GF is.
2021-03-01
- Seventh GF Summer School, in Singapore and online, 26 July – 8 August 2021. + Seventh GF Summer School, in Singapore and online, 26 July – 6 August 2021.
2020-09-29
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 0e5c61404..2f2e802e0 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-} module GF.Command.Commands ( PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands, options,flags, @@ -741,7 +741,7 @@ pgfCommands = Map.fromList [ Nothing -> do putStrLn ("unknown category of function identifier "++show id) return void [e] -> case inferExpr pgf e of - Left tcErr -> error $ render (ppTcError tcErr) + Left tcErr -> errorWithoutStackTrace $ render (ppTcError tcErr) Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e) putStrLn ("Type: "++showType [] ty) putStrLn ("Probability: "++show (probTree pgf e)) @@ -1019,3 +1019,7 @@ stanzas = map unlines . chop . lines where chop ls = case break (=="") ls of (ls1,[]) -> [ls1] (ls1,_:ls2) -> ls1 : chop ls2 + +#if !(MIN_VERSION_base(4,9,0)) +errorWithoutStackTrace = error +#endif \ No newline at end of file diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs index 0b698e79c..c685fc525 100644 --- a/src/compiler/GF/Command/CommonCommands.hs +++ b/src/compiler/GF/Command/CommonCommands.hs @@ -15,6 +15,7 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt) import GF.Text.Pretty import GF.Text.Transliterations import GF.Text.Lexing(stringOp,opInEnv) +import Data.Char (isSpace) import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..)) @@ -170,7 +171,8 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [ restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo fmap fromString $ restricted $ readFile tmpo, -} - fmap fromString . restricted . readShellProcess syst $ toString arg, + fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg, + flags = [ ("command","the system command applied to the argument") ], diff --git a/src/compiler/GF/Command/SourceCommands.hs b/src/compiler/GF/Command/SourceCommands.hs index 0ba60d245..91ada899d 100644 --- a/src/compiler/GF/Command/SourceCommands.hs +++ b/src/compiler/GF/Command/SourceCommands.hs @@ -18,8 +18,8 @@ import GF.Grammar.Parser (runP, pExp) import GF.Grammar.ShowTerm import GF.Grammar.Lookup (allOpers,allOpersTo) import GF.Compile.Rename(renameSourceTerm) -import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues) -import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType) +import GF.Compile.Compute.Concrete(normalForm,resourceValues) +import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType) import GF.Infra.Dependencies(depGraph) import GF.Infra.CheckM(runCheck) @@ -259,7 +259,7 @@ checkComputeTerm os sgr t = ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t inferLType sgr [] t let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os}) - t1 = CN.normalForm (CN.resourceValues opts sgr) (L NoLoc identW) t + t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t t2 = evalStr t1 checkPredefError t2 where diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index f9ab8afcf..59448ce97 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -18,7 +18,7 @@ import Data.List -------------------------- cf2pgf :: FilePath -> ParamCFG -> PGF -cf2pgf fpath cf = +cf2pgf fpath cf = let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf)) in updateProductionIndices pgf where @@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0)) | (cat,rules) <- (Map.toList . Map.fromListWith (++)) - [(cat2id cat, catRules cfg cat) | + [(cat2id cat, catRules cfg cat) | cat <- allCats' cfg]] afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0)) | rule <- allRules cfg] @@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty cats = allCats' cfg rules = allRules cfg - sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : + sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : map mkSequence rules) sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0) @@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty mkLinDefRef (cat,_) = (cat2fid cat 0,[0]) - + addProd prods (fid,prod) = case IntMap.lookup fid prods of Just set -> IntMap.insert fid (Set.insert prod set) prods @@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty mkRuleName rule = case ruleName rule of - CFObj n _ -> n - _ -> wildCId + CFObj n _ -> n + _ -> wildCId diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 24582bba2..7f053f85c 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/11 23:24:33 $ +-- > CVS $Date: 2005/11/11 23:24:33 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.31 $ -- @@ -27,9 +27,9 @@ import GF.Infra.Ident import GF.Infra.Option import GF.Compile.TypeCheck.Abstract -import GF.Compile.TypeCheck.RConcrete -import qualified GF.Compile.TypeCheck.ConcreteNew as CN -import qualified GF.Compile.Compute.ConcreteNew as CN +import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType) +import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType) +import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues) import GF.Grammar import GF.Grammar.Lexer @@ -74,9 +74,9 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty let (incl,excl) = partition (isInherited mi) (Map.keys (jments m)) let incld c = Set.member c (Set.fromList incl) let illegal c = Set.member c (Set.fromList excl) - let illegals = [(f,is) | + let illegals = [(f,is) | (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] - case illegals of + case illegals of [] -> return () cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$ nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs])) @@ -92,12 +92,12 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc -- check that all abstract constants are in concrete; build default lin and lincats jsc <- foldM checkAbs jsc (Map.toList jsa) - + return (cm,cnc{jments=jsc}) where checkAbs js i@(c,info) = case info of - AbsFun (Just (L loc ty)) _ _ _ + AbsFun (Just (L loc ty)) _ _ _ -> do let mb_def = do let (cxt,(_,i),_) = typeForm ty info <- lookupIdent i js @@ -136,11 +136,11 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}") return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js _ -> return js - + checkCnc js (c,info) = case info of CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of - Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> + Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> do (cont,val) <- linTypeOfType gr cm ty let linty = (snd (valCat ty),cont,val) return $ Map.insert c (CncFun (Just linty) d mn mf) js @@ -159,14 +159,14 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc _ -> return $ Map.insert c info js --- | General Principle: only Just-values are checked. +-- | General Principle: only Just-values are checked. -- A May-value has always been checked in its origin module. checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do checkReservedId c case info of - AbsCat (Just (L loc cont)) -> - mkCheck loc "the category" $ + AbsCat (Just (L loc cont)) -> + mkCheck loc "the category" $ checkContext gr cont AbsFun (Just (L loc typ0)) ma md moper -> do @@ -175,13 +175,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do checkTyp gr typ case md of Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $ - checkDef gr (m,c) typ eq) eqs + checkDef gr (m,c) typ eq) eqs Nothing -> return () return (AbsFun (Just (L loc typ)) ma md moper) CncCat mty mdef mref mpr mpmcfg -> do mty <- case mty of - Just (L loc typ) -> chIn loc "linearization type of" $ + Just (L loc typ) -> chIn loc "linearization type of" $ (if False --flag optNewComp opts then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType typ <- computeLType gr [] typ @@ -191,19 +191,19 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do return (Just (L loc typ))) Nothing -> return Nothing mdef <- case (mty,mdef) of - (Just (L _ typ),Just (L loc def)) -> + (Just (L _ typ),Just (L loc def)) -> chIn loc "default linearization of" $ do (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) return (Just (L loc def)) _ -> return Nothing mref <- case (mty,mref) of - (Just (L _ typ),Just (L loc ref)) -> + (Just (L _ typ),Just (L loc ref)) -> chIn loc "reference linearization of" $ do (ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr) return (Just (L loc ref)) _ -> return Nothing mpr <- case mpr of - (Just (L loc t)) -> + (Just (L loc t)) -> chIn loc "print name of" $ do (t,_) <- checkLType gr [] t typeStr return (Just (L loc t)) @@ -212,13 +212,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do CncFun mty mt mpr mpmcfg -> do mt <- case (mty,mt) of - (Just (cat,cont,val),Just (L loc trm)) -> + (Just (cat,cont,val),Just (L loc trm)) -> chIn loc "linearization of" $ do (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars return (Just (L loc trm)) _ -> return mt mpr <- case mpr of - (Just (L loc t)) -> + (Just (L loc t)) -> chIn loc "print name of" $ do (t,_) <- checkLType gr [] t typeStr return (Just (L loc t)) @@ -251,16 +251,16 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do ResOverload os tysts -> chIn NoLoc "overloading" $ do tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones tysts0 <- lookupOverload gr (m,c) -- check against inherited ones too - tysts1 <- mapM (uncurry $ flip (checkLType gr [])) + tysts1 <- mapM (uncurry $ flip (checkLType gr [])) [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] --- this can only be a partial guarantee, since matching --- with value type is only possible if expected type is given - checkUniq $ + checkUniq $ sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1] return (ResOverload os [(y,x) | (x,y) <- tysts']) ResParam (Just (L loc pcs)) _ -> do - ts <- chIn loc "parameter type" $ + ts <- chIn loc "parameter type" $ liftM concat $ mapM mkPar pcs return (ResParam (Just (L loc pcs)) (Just ts)) @@ -274,9 +274,9 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do return $ map (mkApp (QC (m,f))) vs checkUniq xss = case xss of - x:y:xs + x:y:xs | x == y -> checkError $ "ambiguous for type" <+> - ppType (mkFunType (tail x) (head x)) + ppType (mkFunType (tail x) (head x)) | otherwise -> checkUniq $ y:xs _ -> return () @@ -294,7 +294,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do t' <- compAbsTyp ((x,Vr x):g) t return $ Prod b x a' t' Abs _ _ _ -> return t - _ -> composOp (compAbsTyp g) t + _ -> composOp (compAbsTyp g) t -- | for grammars obtained otherwise than by parsing ---- update!! @@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do mkLinArg (i,(n,mc@(m,cat))) = do val <- lookLin mc let vars = mkRecType varLabel $ replicate n typeStr - symb = argIdent n cat i + symb = argIdent n cat i rec <- if n==0 then return val else errIn (render ("extending" $$ nest 2 vars $$ diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index f411f2ca0..47e2f5cde 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -1,3 +1,590 @@ -module GF.Compile.Compute.Concrete{-(module M)-} where ---import GF.Compile.Compute.ConcreteLazy as M -- New ---import GF.Compile.Compute.ConcreteStrict as M -- Old, inefficient +-- | Functions for computing the values of terms in the concrete syntax, in +-- | preparation for PMCFG generation. +module GF.Compile.Compute.Concrete + (GlobalEnv, GLocation, resourceValues, geLoc, geGrammar, + normalForm, + Value(..), Bind(..), Env, value2term, eval, vapply + ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint + +import GF.Grammar hiding (Env, VGen, VApp, VRecType) +import GF.Grammar.Lookup(lookupResDefLoc,allParamValues) +import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool) +import GF.Grammar.PatternMatch(matchPattern,measurePatt) +import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel +import GF.Compile.Compute.Value hiding (Error) +import GF.Compile.Compute.Predef(predef,predefName,delta) +import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok) +import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM) +import GF.Data.Utilities(mapFst,mapSnd) +import GF.Infra.Option +import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus +import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf +--import Data.Char (isUpper,toUpper,toLower) +import GF.Text.Pretty +import qualified Data.Map as Map +import Debug.Trace(trace) + +-- * Main entry points + +normalForm :: GlobalEnv -> L Ident -> Term -> Term +normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc) + +nfx :: GlobalEnv -> Term -> Err Term +nfx env@(GE _ _ _ loc) t = do + v <- eval env [] t + return (value2term loc [] v) + -- Old value2term error message: + -- Left i -> fail ("variable #"++show i++" is out of scope") + +eval :: GlobalEnv -> Env -> Term -> Err Value +eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t + where + cenv = CE gr rvs opts loc (map fst env) + +--apply env = apply' env + +-------------------------------------------------------------------------------- + +-- * Environments + +type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value)) + +data GlobalEnv = GE Grammar ResourceValues Options GLocation +data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues, + opts::Options, + gloc::GLocation,local::LocalScope} +type GLocation = L Ident +type LocalScope = [Ident] +type Stack = [Value] +type OpenValue = Stack->Value + +geLoc (GE _ _ _ loc) = loc +geGrammar (GE gr _ _ _) = gr + +ext b env = env{local=b:local env} +extend bs env = env{local=bs++local env} +global env = GE (srcgr env) (rvs env) (opts env) (gloc env) + +var :: CompleteEnv -> Ident -> Err OpenValue +var env x = maybe unbound pick' (elemIndex x (local env)) + where + unbound = fail ("Unknown variable: "++showIdent x) + pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs) + err i vs = bug $ "Stack problem: "++showIdent x++": " + ++unwords (map showIdent (local env)) + ++" => "++show (i,length vs) + ok v = --trace ("var "++show x++" = "++show v) $ + v + +pick :: Int -> Stack -> Maybe Value +pick 0 (v:_) = Just v +pick i (_:vs) = pick (i-1) vs +pick i vs = Nothing -- bug $ "pick "++show (i,vs) + +resource env (m,c) = +-- err bug id $ + if isPredefCat c + then value0 env =<< lockRecType c defLinType -- hmm + else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env) + where e = fail $ "Not found: "++render m++"."++showIdent c + +-- | Convert operators once, not every time they are looked up +resourceValues :: Options -> SourceGrammar -> GlobalEnv +resourceValues opts gr = env + where + env = GE gr rvs opts (L NoLoc identW) + rvs = Map.mapWithKey moduleResources (moduleMap gr) + moduleResources m = Map.mapWithKey (moduleResource m) . jments + moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c) + let loc = L l c + qloc = L l (Q (m,c)) + eval (GE gr rvs opts loc) [] (traceRes qloc t) + + traceRes = if flag optTrace opts + then traceResource + else const id + +-- * Tracing + +-- | Insert a call to the trace function under the top-level lambdas +traceResource (L l q) t = + case termFormCnc t of + (abs,body) -> mkAbs abs (mkApp traceQ [args,body]) + where + args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit]) + lstr = render (l<>":"<>ppTerm Qualified 0 q) + traceQ = Q (cPredef,cTrace) + +-- * Computing values + +-- | Computing the value of a top-level term +value0 :: CompleteEnv -> Term -> Err Value +value0 env = eval (global env) [] + +-- | Computing the value of a term +value :: CompleteEnv -> Term -> Err OpenValue +value env t0 = + -- Each terms is traversed only once by this function, using only statically + -- available information. Notably, the values of lambda bound variables + -- will be unknown during the term traversal phase. + -- The result is an OpenValue, which is a function that may be applied many + -- times to different dynamic values, but without the term traversal overhead + -- and without recomputing other statically known information. + -- For this to work, there should be no recursive calls under lambdas here. + -- Whenever we need to construct the OpenValue function with an explicit + -- lambda, we have to lift the recursive calls outside the lambda. + -- (See e.g. the rules for Let, Prod and Abs) +{- + trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":", + brackets (fsep (map ppIdent (local env))), + ppTerm Unqualified 10 t0]) $ +--} + errIn (render t0) $ + case t0 of + Vr x -> var env x + Q x@(m,f) + | m == cPredef -> if f==cErrorType -- to be removed + then let p = identS "P" + in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) []) + else if f==cPBool + then const # resource env x + else const . flip VApp [] # predef f + | otherwise -> const # resource env x --valueResDef (fst env) x + QC x -> return $ const (VCApp x []) + App e1 e2 -> apply' env e1 . (:[]) =<< value env e2 + Let (x,(oty,t)) body -> do vb <- value (ext x env) body + vt <- value env t + return $ \ vs -> vb (vt vs:vs) + Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) [] + Prod bt x t1 t2 -> + do vt1 <- value env t1 + vt2 <- value (ext x env) t2 + return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs) + Abs bt x t -> do vt <- value (ext x env) t + return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs) + EInt n -> return $ const (VInt n) + EFloat f -> return $ const (VFloat f) + K s -> return $ const (VString s) + Empty -> return $ const (VString "") + Sort s | s == cTok -> return $ const (VSort cStr) -- to be removed + | otherwise -> return $ const (VSort s) + ImplArg t -> (VImplArg.) # value env t + Table p res -> liftM2 VTblType # value env p <# value env res + RecType rs -> do lovs <- mapPairsM (value env) rs + return $ \vs->VRecType $ mapSnd ($vs) lovs + t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2) + FV ts -> ((vfv .) # sequence) # mapM (value env) ts + R as -> do lovs <- mapPairsM (value env.snd) as + return $ \ vs->VRec $ mapSnd ($vs) lovs + T i cs -> valueTable env i cs + V ty ts -> do pvs <- paramValues env ty + ((VV ty pvs .) . sequence) # mapM (value env) ts + C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2) + S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2) + P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $ + do ov <- value env t + return $ \ vs -> let v = ov vs + in maybe (VP v l) id (proj l v) + Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts + Strs ts -> ((VStrs.) # sequence) # mapM (value env) ts + Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2) + ELin c r -> (unlockVRec (gloc env) c.) # value env r + EPatt p -> return $ const (VPatt p) -- hmm + EPattType ty -> do vt <- value env ty + return (VPattType . vt) + Typed t ty -> value env t + t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t + +vconcat vv@(v1,v2) = + case vv of + (VString "",_) -> v2 + (_,VString "") -> v1 + (VApp NonExist _,_) -> v1 + (_,VApp NonExist _) -> v2 + _ -> VC v1 v2 + +proj l v | isLockLabel l = return (VRec []) + ---- a workaround 18/2/2005: take this away and find the reason + ---- why earlier compilation destroys the lock field +proj l v = + case v of + VFV vs -> liftM vfv (mapM (proj l) vs) + VRec rs -> lookup l rs +-- VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm + VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs + _ -> return (ok1 VP v l) + +ok1 f v1@(VError {}) _ = v1 +ok1 f v1 v2 = f v1 v2 + +ok2 f v1@(VError {}) _ = v1 +ok2 f _ v2@(VError {}) = v2 +ok2 f v1 v2 = f v1 v2 + +ok2p f (v1@VError {},_) = v1 +ok2p f (_,v2@VError {}) = v2 +ok2p f vv = f vv + +unlockVRec loc c0 v0 = v0 +{- +unlockVRec loc c0 v0 = unlockVRec' c0 v0 + where + unlockVRec' ::Ident -> Value -> Value + unlockVRec' c v = + case v of + -- VClosure env t -> err bug (VClosure env) (unlockRecord c t) + VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v)) + VRec rs -> plusVRec rs lock + -- _ -> VExtR v (VRec lock) -- hmm + _ -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm + -- _ -> bugloc loc $ "unlock non-record "++show v0 + where + lock = [(lockLabel c,VRec [])] +-} + +-- suspicious, but backwards compatible +plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2) + where ls2 = map fst rs2 + +extR t vv = + case vv of + (VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs] + (v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs] + (VRecType rs1, VRecType rs2) -> + case intersect (map fst rs1) (map fst rs2) of + [] -> VRecType (rs1 ++ rs2) + ls -> error $ "clash"<+>show ls + (VRec rs1, VRec rs2) -> plusVRec rs1 rs2 + (v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm + (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s +-- (v1,v2) -> ok2 VExtR v1 v2 -- hmm + (v1,v2) -> error $ "not records" $$ show v1 $$ show v2 + where + error explain = ppbug $ "The term" <+> t + <+> "is not reducible" $$ explain + +glue env (v1,v2) = glu v1 v2 + where + glu v1 v2 = + case (v1,v2) of + (VFV vs,v2) -> vfv [glu v1 v2|v1<-vs] + (v1,VFV vs) -> vfv [glu v1 v2|v2<-vs] + (VString s1,VString s2) -> VString (s1++s2) + (v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs] + where glx v2 = glu v1 v2 + (v1@(VAlts {}),v2) -> + --err (const (ok2 VGlue v1 v2)) id $ + err bug id $ + do y' <- strsFromValue v2 + x' <- strsFromValue v1 + return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y'] + (VC va vb,v2) -> VC va (glu vb v2) + (v1,VC va vb) -> VC (glu v1 va) vb + (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb + (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb + (v1@(VApp NonExist _),_) -> v1 + (_,v2@(VApp NonExist _)) -> v2 +-- (v1,v2) -> ok2 VGlue v1 v2 + (v1,v2) -> if flag optPlusAsBind (opts env) + then VC v1 (VC (VApp BIND []) v2) + else let loc = gloc env + vt v = value2term loc (local env) v + -- Old value2term error message: + -- Left i -> Error ('#':show i) + originalMsg = render $ ppL loc (hang "unsupported token gluing" 4 + (Glue (vt v1) (vt v2))) + term = render $ pp $ Glue (vt v1) (vt v2) + in error $ unlines + [originalMsg + ,"" + ,"There was a problem in the expression `"++term++"`, either:" + ,"1) You are trying to use + on runtime arguments, possibly via an oper." + ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive." + ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md" + ] + + +-- | to get a string from a value that represents a sequence of terminals +strsFromValue :: Value -> Err [Str] +strsFromValue t = case t of + VString s -> return [str s] + VC s t -> do + s' <- strsFromValue s + t' <- strsFromValue t + return [plusStr x y | x <- s', y <- t'] +{- + VGlue s t -> do + s' <- strsFromValue s + t' <- strsFromValue t + return [glueStr x y | x <- s', y <- t'] +-} + VAlts d vs -> do + d0 <- strsFromValue d + v0 <- mapM (strsFromValue . fst) vs + c0 <- mapM (strsFromValue . snd) vs + --let vs' = zip v0 c0 + return [strTok (str2strings def) vars | + def <- d0, + vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | + vv <- sequence v0] + ] + VFV ts -> concat # mapM strsFromValue ts + VStrs ts -> concat # mapM strsFromValue ts + + _ -> fail ("cannot get Str from value " ++ show t) + +vfv vs = case nub vs of + [v] -> v + vs -> VFV vs + +select env vv = + case vv of + (v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs] + (VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs] + (v1@(VV pty vs rs),v2) -> + err (const (VS v1 v2)) id $ + do --ats <- allParamValues (srcgr env) pty + --let vs = map (value0 env) ats + i <- maybeErr "no match" $ findIndex (==v2) vs + return (ix (gloc env) "select" rs i) + (VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b [] + (v1@(VT _ _ cs),v2) -> + err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $ + match (gloc env) cs v2 + (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12 + (v1,v2) -> ok2 VS v1 v2 + +match loc cs v = + err bad return (matchPattern cs (value2term loc [] v)) + -- Old value2term error message: + -- Left i -> bad ("variable #"++show i++" is out of scope") + where + bad = fail . ("In pattern matching: "++) + +valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value +valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env' + +valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue +valueTable env i cs = + case i of + TComp ty -> do pvs <- paramValues env ty + ((VV ty pvs .) # sequence) # mapM (value env.snd) cs + _ -> do ty <- getTableType i + cs' <- mapM valueCase cs + err (dynamic cs' ty) return (convert cs' ty) + where + dynamic cs' ty _ = cases cs' # value env ty + + cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs)) + where + keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $ + VT wild (vty vs) (mapSnd ($vs) cs') + + wild = case i of TWild _ -> True; _ -> False + + convertv cs' vty = + convert' cs' =<< paramValues'' env (value2term (gloc env) [] vty) + -- Old value2term error message: Left i -> fail ("variable #"++show i++" is out of scope") + + convert cs' ty = convert' cs' =<< paramValues' env ty + + convert' cs' ((pty,vs),pvs) = + do sts <- mapM (matchPattern cs') vs + return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env) + (mapFst ($vs) sts) + + valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p + pvs <- linPattVars p' + vt <- value (extend pvs env) t + return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs)) + + inlinePattMacro p = + case p of + PM qc -> do r <- resource env qc + case r of + VPatt p' -> inlinePattMacro p' + _ -> ppbug $ hang "Expected pattern macro:" 4 + (show r) + _ -> composPattOp inlinePattMacro p + + +paramValues env ty = snd # paramValues' env ty + +paramValues' env ty = paramValues'' env =<< nfx (global env) ty + +paramValues'' env pty = do ats <- allParamValues (srcgr env) pty + pvs <- mapM (eval (global env) []) ats + return ((pty,ats),pvs) + +push' p bs xs = if length bs/=length xs + then bug $ "push "++show (p,bs,xs) + else push bs xs + +push :: Env -> LocalScope -> Stack -> Stack +push bs [] vs = vs +push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs + where err = bug $ "Unbound pattern variable "++showIdent x + +apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue +apply' env t [] = value env t +apply' env t vs = + case t of + QC x -> return $ \ svs -> VCApp x (map ($svs) vs) +{- + Q x@(m,f) | m==cPredef -> return $ + let constr = --trace ("predef "++show x) . + VApp x + in \ svs -> maybe constr id (Map.lookup f predefs) + $ map ($svs) vs + | otherwise -> do r <- resource env x + return $ \ svs -> vapply (gloc env) r (map ($svs) vs) +-} + App t1 t2 -> apply' env t1 . (:vs) =<< value env t2 + _ -> do fv <- value env t + return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs) + +vapply :: GLocation -> Value -> [Value] -> Value +vapply loc v [] = v +vapply loc v vs = + case v of + VError {} -> v +-- VClosure env (Abs b x t) -> beta gr env b x t vs + VAbs bt _ (Bind f) -> vbeta loc bt f vs + VApp pre vs1 -> delta' pre (vs1++vs) + where + delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs + in vtrace loc v1 vr + delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs) + --msg = const (VApp pre (vs1++vs)) + msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++) + VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s + VFV fs -> vfv [vapply loc f vs|f<-fs] + VCApp f vs0 -> VCApp f (vs0++vs) + VMeta i env vs0 -> VMeta i env (vs0++vs) + VGen i vs0 -> VGen i (vs0++vs) + v -> bug $ "vapply "++show v++" "++show vs + +vbeta loc bt f (v:vs) = + case (bt,v) of + (Implicit,VImplArg v) -> ap v + (Explicit, v) -> ap v + where + ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs] + ap v = vapply loc (f v) vs + +vary (VFV vs) = vs +vary v = [v] +varyList = mapM vary + +{- +beta env b x t (v:vs) = + case (b,v) of + (Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs + (Explicit, v) -> apply' (ext (x,v) env) t vs +-} + +vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res + where + pv v = case v of + VRec (f:as) -> hang (pf f) 4 (fsep (map pa as)) + _ -> ppV v + pf (_,VString n) = pp n + pf (_,v) = ppV v + pa (_,v) = ppV v + ppV v = ppTerm Unqualified 10 (value2term' True loc [] v) + -- Old value2term error message: + -- Left i -> "variable #" <> pp i <+> "is out of scope" + +-- | Convert a value back to a term +value2term :: GLocation -> [Ident] -> Value -> Term +value2term = value2term' False + +value2term' :: Bool -> p -> [Ident] -> Value -> Term +value2term' stop loc xs v0 = + case v0 of + VApp pre vs -> applyMany (Q (cPredef,predefName pre)) vs + VCApp f vs -> applyMany (QC f) vs + VGen j vs -> applyMany (var j) vs + VMeta j env vs -> applyMany (Meta j) vs + VProd bt v x f -> Prod bt x (v2t v) (v2t' x f) + VAbs bt x f -> Abs bt x (v2t' x f) + VInt n -> EInt n + VFloat f -> EFloat f + VString s -> if null s then Empty else K s + VSort s -> Sort s + VImplArg v -> ImplArg (v2t v) + VTblType p res -> Table (v2t p) (v2t res) + VRecType rs -> RecType [(l, v2t v) | (l,v) <- rs] + VRec as -> R [(l, (Nothing, v2t v)) | (l,v) <- as] + VV t _ vs -> V t (map v2t vs) + VT wild v cs -> T ((if wild then TWild else TTyped) (v2t v)) (map nfcase cs) + VFV vs -> FV (map v2t vs) + VC v1 v2 -> C (v2t v1) (v2t v2) + VS v1 v2 -> S (v2t v1) (v2t v2) + VP v l -> P (v2t v) l + VPatt p -> EPatt p + VPattType v -> EPattType $ v2t v + VAlts v vvs -> Alts (v2t v) [(v2t x, v2t y) | (x,y) <- vvs] + VStrs vs -> Strs (map v2t vs) +-- VGlue v1 v2 -> Glue (v2t v1) (v2t v2) +-- VExtR v1 v2 -> ExtR (v2t v1) (v2t v2) + VError err -> Error err + where + applyMany f vs = foldl App f (map v2t vs) + v2t = v2txs xs + v2txs = value2term' stop loc + v2t' x f = v2txs (x:xs) (bind f (gen xs)) + + var j + | j [i] + PAs i p -> i:allPattVars p + _ -> collectPattOp allPattVars p + +--- +ix loc fn xs i = + if i)) -- GHC 8.4.1 clash with Text.PrettyPrint - -import GF.Grammar hiding (Env, VGen, VApp, VRecType) -import GF.Grammar.Lookup(lookupResDefLoc,allParamValues) -import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool) -import GF.Grammar.PatternMatch(matchPattern,measurePatt) -import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel -import GF.Compile.Compute.Value hiding (Error) -import GF.Compile.Compute.Predef(predef,predefName,delta) -import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok) -import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM) -import GF.Data.Utilities(mapFst,mapSnd) -import GF.Infra.Option -import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus -import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf ---import Data.Char (isUpper,toUpper,toLower) -import GF.Text.Pretty -import qualified Data.Map as Map -import Debug.Trace(trace) - --- * Main entry points - -normalForm :: GlobalEnv -> L Ident -> Term -> Term -normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc) - -nfx env@(GE _ _ _ loc) t = do - v <- eval env [] t - case value2term loc [] v of - Left i -> fail ("variable #"++show i++" is out of scope") - Right t -> return t - -eval :: GlobalEnv -> Env -> Term -> Err Value -eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t - where - cenv = CE gr rvs opts loc (map fst env) - ---apply env = apply' env - --------------------------------------------------------------------------------- - --- * Environments - -type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value)) - -data GlobalEnv = GE Grammar ResourceValues Options GLocation -data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues, - opts::Options, - gloc::GLocation,local::LocalScope} -type GLocation = L Ident -type LocalScope = [Ident] -type Stack = [Value] -type OpenValue = Stack->Value - -geLoc (GE _ _ _ loc) = loc -geGrammar (GE gr _ _ _) = gr - -ext b env = env{local=b:local env} -extend bs env = env{local=bs++local env} -global env = GE (srcgr env) (rvs env) (opts env) (gloc env) - -var :: CompleteEnv -> Ident -> Err OpenValue -var env x = maybe unbound pick' (elemIndex x (local env)) - where - unbound = fail ("Unknown variable: "++showIdent x) - pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs) - err i vs = bug $ "Stack problem: "++showIdent x++": " - ++unwords (map showIdent (local env)) - ++" => "++show (i,length vs) - ok v = --trace ("var "++show x++" = "++show v) $ - v - -pick :: Int -> Stack -> Maybe Value -pick 0 (v:_) = Just v -pick i (_:vs) = pick (i-1) vs -pick i vs = Nothing -- bug $ "pick "++show (i,vs) - -resource env (m,c) = --- err bug id $ - if isPredefCat c - then value0 env =<< lockRecType c defLinType -- hmm - else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env) - where e = fail $ "Not found: "++render m++"."++showIdent c - --- | Convert operators once, not every time they are looked up -resourceValues :: Options -> SourceGrammar -> GlobalEnv -resourceValues opts gr = env - where - env = GE gr rvs opts (L NoLoc identW) - rvs = Map.mapWithKey moduleResources (moduleMap gr) - moduleResources m = Map.mapWithKey (moduleResource m) . jments - moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c) - let loc = L l c - qloc = L l (Q (m,c)) - eval (GE gr rvs opts loc) [] (traceRes qloc t) - - traceRes = if flag optTrace opts - then traceResource - else const id - --- * Tracing - --- | Insert a call to the trace function under the top-level lambdas -traceResource (L l q) t = - case termFormCnc t of - (abs,body) -> mkAbs abs (mkApp traceQ [args,body]) - where - args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit]) - lstr = render (l<>":"<>ppTerm Qualified 0 q) - traceQ = Q (cPredef,cTrace) - --- * Computing values - --- | Computing the value of a top-level term -value0 :: CompleteEnv -> Term -> Err Value -value0 env = eval (global env) [] - --- | Computing the value of a term -value :: CompleteEnv -> Term -> Err OpenValue -value env t0 = - -- Each terms is traversed only once by this function, using only statically - -- available information. Notably, the values of lambda bound variables - -- will be unknown during the term traversal phase. - -- The result is an OpenValue, which is a function that may be applied many - -- times to different dynamic values, but without the term traversal overhead - -- and without recomputing other statically known information. - -- For this to work, there should be no recursive calls under lambdas here. - -- Whenever we need to construct the OpenValue function with an explicit - -- lambda, we have to lift the recursive calls outside the lambda. - -- (See e.g. the rules for Let, Prod and Abs) -{- - trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":", - brackets (fsep (map ppIdent (local env))), - ppTerm Unqualified 10 t0]) $ ---} - errIn (render t0) $ - case t0 of - Vr x -> var env x - Q x@(m,f) - | m == cPredef -> if f==cErrorType -- to be removed - then let p = identS "P" - in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) []) - else if f==cPBool - then const # resource env x - else const . flip VApp [] # predef f - | otherwise -> const # resource env x --valueResDef (fst env) x - QC x -> return $ const (VCApp x []) - App e1 e2 -> apply' env e1 . (:[]) =<< value env e2 - Let (x,(oty,t)) body -> do vb <- value (ext x env) body - vt <- value env t - return $ \ vs -> vb (vt vs:vs) - Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) [] - Prod bt x t1 t2 -> - do vt1 <- value env t1 - vt2 <- value (ext x env) t2 - return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs) - Abs bt x t -> do vt <- value (ext x env) t - return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs) - EInt n -> return $ const (VInt n) - EFloat f -> return $ const (VFloat f) - K s -> return $ const (VString s) - Empty -> return $ const (VString "") - Sort s | s == cTok -> return $ const (VSort cStr) -- to be removed - | otherwise -> return $ const (VSort s) - ImplArg t -> (VImplArg.) # value env t - Table p res -> liftM2 VTblType # value env p <# value env res - RecType rs -> do lovs <- mapPairsM (value env) rs - return $ \vs->VRecType $ mapSnd ($vs) lovs - t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2) - FV ts -> ((vfv .) # sequence) # mapM (value env) ts - R as -> do lovs <- mapPairsM (value env.snd) as - return $ \ vs->VRec $ mapSnd ($vs) lovs - T i cs -> valueTable env i cs - V ty ts -> do pvs <- paramValues env ty - ((VV ty pvs .) . sequence) # mapM (value env) ts - C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2) - S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2) - P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $ - do ov <- value env t - return $ \ vs -> let v = ov vs - in maybe (VP v l) id (proj l v) - Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts - Strs ts -> ((VStrs.) # sequence) # mapM (value env) ts - Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2) - ELin c r -> (unlockVRec (gloc env) c.) # value env r - EPatt p -> return $ const (VPatt p) -- hmm - EPattType ty -> do vt <- value env ty - return (VPattType . vt) - Typed t ty -> value env t - t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t - -vconcat vv@(v1,v2) = - case vv of - (VString "",_) -> v2 - (_,VString "") -> v1 - (VApp NonExist _,_) -> v1 - (_,VApp NonExist _) -> v2 - _ -> VC v1 v2 - -proj l v | isLockLabel l = return (VRec []) - ---- a workaround 18/2/2005: take this away and find the reason - ---- why earlier compilation destroys the lock field -proj l v = - case v of - VFV vs -> liftM vfv (mapM (proj l) vs) - VRec rs -> lookup l rs --- VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm - VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs - _ -> return (ok1 VP v l) - -ok1 f v1@(VError {}) _ = v1 -ok1 f v1 v2 = f v1 v2 - -ok2 f v1@(VError {}) _ = v1 -ok2 f _ v2@(VError {}) = v2 -ok2 f v1 v2 = f v1 v2 - -ok2p f (v1@VError {},_) = v1 -ok2p f (_,v2@VError {}) = v2 -ok2p f vv = f vv - -unlockVRec loc c0 v0 = v0 -{- -unlockVRec loc c0 v0 = unlockVRec' c0 v0 - where - unlockVRec' ::Ident -> Value -> Value - unlockVRec' c v = - case v of - -- VClosure env t -> err bug (VClosure env) (unlockRecord c t) - VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v)) - VRec rs -> plusVRec rs lock - -- _ -> VExtR v (VRec lock) -- hmm - _ -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm - -- _ -> bugloc loc $ "unlock non-record "++show v0 - where - lock = [(lockLabel c,VRec [])] --} - --- suspicious, but backwards compatible -plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2) - where ls2 = map fst rs2 - -extR t vv = - case vv of - (VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs] - (v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs] - (VRecType rs1, VRecType rs2) -> - case intersect (map fst rs1) (map fst rs2) of - [] -> VRecType (rs1 ++ rs2) - ls -> error $ "clash"<+>show ls - (VRec rs1, VRec rs2) -> plusVRec rs1 rs2 - (v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm - (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s --- (v1,v2) -> ok2 VExtR v1 v2 -- hmm - (v1,v2) -> error $ "not records" $$ show v1 $$ show v2 - where - error explain = ppbug $ "The term" <+> t - <+> "is not reducible" $$ explain - -glue env (v1,v2) = glu v1 v2 - where - glu v1 v2 = - case (v1,v2) of - (VFV vs,v2) -> vfv [glu v1 v2|v1<-vs] - (v1,VFV vs) -> vfv [glu v1 v2|v2<-vs] - (VString s1,VString s2) -> VString (s1++s2) - (v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs] - where glx v2 = glu v1 v2 - (v1@(VAlts {}),v2) -> - --err (const (ok2 VGlue v1 v2)) id $ - err bug id $ - do y' <- strsFromValue v2 - x' <- strsFromValue v1 - return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y'] - (VC va vb,v2) -> VC va (glu vb v2) - (v1,VC va vb) -> VC (glu v1 va) vb - (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb - (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb - (v1@(VApp NonExist _),_) -> v1 - (_,v2@(VApp NonExist _)) -> v2 --- (v1,v2) -> ok2 VGlue v1 v2 - (v1,v2) -> if flag optPlusAsBind (opts env) - then VC v1 (VC (VApp BIND []) v2) - else let loc = gloc env - vt v = case value2term loc (local env) v of - Left i -> Error ('#':show i) - Right t -> t - originalMsg = render $ ppL loc (hang "unsupported token gluing" 4 - (Glue (vt v1) (vt v2))) - term = render $ pp $ Glue (vt v1) (vt v2) - in error $ unlines - [originalMsg - ,"" - ,"There was a problem in the expression `"++term++"`, either:" - ,"1) You are trying to use + on runtime arguments, possibly via an oper." - ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive." - ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md" - ] - - --- | to get a string from a value that represents a sequence of terminals -strsFromValue :: Value -> Err [Str] -strsFromValue t = case t of - VString s -> return [str s] - VC s t -> do - s' <- strsFromValue s - t' <- strsFromValue t - return [plusStr x y | x <- s', y <- t'] -{- - VGlue s t -> do - s' <- strsFromValue s - t' <- strsFromValue t - return [glueStr x y | x <- s', y <- t'] --} - VAlts d vs -> do - d0 <- strsFromValue d - v0 <- mapM (strsFromValue . fst) vs - c0 <- mapM (strsFromValue . snd) vs - --let vs' = zip v0 c0 - return [strTok (str2strings def) vars | - def <- d0, - vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | - vv <- sequence v0] - ] - VFV ts -> concat # mapM strsFromValue ts - VStrs ts -> concat # mapM strsFromValue ts - - _ -> fail ("cannot get Str from value " ++ show t) - -vfv vs = case nub vs of - [v] -> v - vs -> VFV vs - -select env vv = - case vv of - (v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs] - (VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs] - (v1@(VV pty vs rs),v2) -> - err (const (VS v1 v2)) id $ - do --ats <- allParamValues (srcgr env) pty - --let vs = map (value0 env) ats - i <- maybeErr "no match" $ findIndex (==v2) vs - return (ix (gloc env) "select" rs i) - (VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b [] - (v1@(VT _ _ cs),v2) -> - err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $ - match (gloc env) cs v2 - (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12 - (v1,v2) -> ok2 VS v1 v2 - -match loc cs v = - case value2term loc [] v of - Left i -> bad ("variable #"++show i++" is out of scope") - Right t -> err bad return (matchPattern cs t) - where - bad = fail . ("In pattern matching: "++) - -valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value -valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env' - -valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue -valueTable env i cs = - case i of - TComp ty -> do pvs <- paramValues env ty - ((VV ty pvs .) # sequence) # mapM (value env.snd) cs - _ -> do ty <- getTableType i - cs' <- mapM valueCase cs - err (dynamic cs' ty) return (convert cs' ty) - where - dynamic cs' ty _ = cases cs' # value env ty - - cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs)) - where - keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $ - VT wild (vty vs) (mapSnd ($vs) cs') - - wild = case i of TWild _ -> True; _ -> False - - convertv cs' vty = - case value2term (gloc env) [] vty of - Left i -> fail ("variable #"++show i++" is out of scope") - Right pty -> convert' cs' =<< paramValues'' env pty - - convert cs' ty = convert' cs' =<< paramValues' env ty - - convert' cs' ((pty,vs),pvs) = - do sts <- mapM (matchPattern cs') vs - return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env) - (mapFst ($vs) sts) - - valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p - pvs <- linPattVars p' - vt <- value (extend pvs env) t - return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs)) - - inlinePattMacro p = - case p of - PM qc -> do r <- resource env qc - case r of - VPatt p' -> inlinePattMacro p' - _ -> ppbug $ hang "Expected pattern macro:" 4 - (show r) - _ -> composPattOp inlinePattMacro p - - -paramValues env ty = snd # paramValues' env ty - -paramValues' env ty = paramValues'' env =<< nfx (global env) ty - -paramValues'' env pty = do ats <- allParamValues (srcgr env) pty - pvs <- mapM (eval (global env) []) ats - return ((pty,ats),pvs) - -push' p bs xs = if length bs/=length xs - then bug $ "push "++show (p,bs,xs) - else push bs xs - -push :: Env -> LocalScope -> Stack -> Stack -push bs [] vs = vs -push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs - where err = bug $ "Unbound pattern variable "++showIdent x - -apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue -apply' env t [] = value env t -apply' env t vs = - case t of - QC x -> return $ \ svs -> VCApp x (map ($svs) vs) -{- - Q x@(m,f) | m==cPredef -> return $ - let constr = --trace ("predef "++show x) . - VApp x - in \ svs -> maybe constr id (Map.lookup f predefs) - $ map ($svs) vs - | otherwise -> do r <- resource env x - return $ \ svs -> vapply (gloc env) r (map ($svs) vs) --} - App t1 t2 -> apply' env t1 . (:vs) =<< value env t2 - _ -> do fv <- value env t - return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs) - -vapply :: GLocation -> Value -> [Value] -> Value -vapply loc v [] = v -vapply loc v vs = - case v of - VError {} -> v --- VClosure env (Abs b x t) -> beta gr env b x t vs - VAbs bt _ (Bind f) -> vbeta loc bt f vs - VApp pre vs1 -> delta' pre (vs1++vs) - where - delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs - in vtrace loc v1 vr - delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs) - --msg = const (VApp pre (vs1++vs)) - msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++) - VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s - VFV fs -> vfv [vapply loc f vs|f<-fs] - VCApp f vs0 -> VCApp f (vs0++vs) - VMeta i env vs0 -> VMeta i env (vs0++vs) - VGen i vs0 -> VGen i (vs0++vs) - v -> bug $ "vapply "++show v++" "++show vs - -vbeta loc bt f (v:vs) = - case (bt,v) of - (Implicit,VImplArg v) -> ap v - (Explicit, v) -> ap v - where - ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs] - ap v = vapply loc (f v) vs - -vary (VFV vs) = vs -vary v = [v] -varyList = mapM vary - -{- -beta env b x t (v:vs) = - case (b,v) of - (Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs - (Explicit, v) -> apply' (ext (x,v) env) t vs --} - -vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res - where - pv v = case v of - VRec (f:as) -> hang (pf f) 4 (fsep (map pa as)) - _ -> ppV v - pf (_,VString n) = pp n - pf (_,v) = ppV v - pa (_,v) = ppV v - ppV v = case value2term' True loc [] v of - Left i -> "variable #" <> pp i <+> "is out of scope" - Right t -> ppTerm Unqualified 10 t - --- | Convert a value back to a term -value2term :: GLocation -> [Ident] -> Value -> Either Int Term -value2term = value2term' False -value2term' stop loc xs v0 = - case v0 of - VApp pre vs -> liftM (foldl App (Q (cPredef,predefName pre))) (mapM v2t vs) - VCApp f vs -> liftM (foldl App (QC f)) (mapM v2t vs) - VGen j vs -> liftM2 (foldl App) (var j) (mapM v2t vs) - VMeta j env vs -> liftM (foldl App (Meta j)) (mapM v2t vs) - VProd bt v x f -> liftM2 (Prod bt x) (v2t v) (v2t' x f) - VAbs bt x f -> liftM (Abs bt x) (v2t' x f) - VInt n -> return (EInt n) - VFloat f -> return (EFloat f) - VString s -> return (if null s then Empty else K s) - VSort s -> return (Sort s) - VImplArg v -> liftM ImplArg (v2t v) - VTblType p res -> liftM2 Table (v2t p) (v2t res) - VRecType rs -> liftM RecType (mapM (\(l,v) -> fmap ((,) l) (v2t v)) rs) - VRec as -> liftM R (mapM (\(l,v) -> v2t v >>= \t -> return (l,(Nothing,t))) as) - VV t _ vs -> liftM (V t) (mapM v2t vs) - VT wild v cs -> v2t v >>= \t -> liftM (T ((if wild then TWild else TTyped) t)) (mapM nfcase cs) - VFV vs -> liftM FV (mapM v2t vs) - VC v1 v2 -> liftM2 C (v2t v1) (v2t v2) - VS v1 v2 -> liftM2 S (v2t v1) (v2t v2) - VP v l -> v2t v >>= \t -> return (P t l) - VPatt p -> return (EPatt p) - VPattType v -> v2t v >>= return . EPattType - VAlts v vvs -> liftM2 Alts (v2t v) (mapM (\(x,y) -> liftM2 (,) (v2t x) (v2t y)) vvs) - VStrs vs -> liftM Strs (mapM v2t vs) --- VGlue v1 v2 -> Glue (v2t v1) (v2t v2) --- VExtR v1 v2 -> ExtR (v2t v1) (v2t v2) - VError err -> return (Error err) - _ -> bug ("value2term "++show loc++" : "++show v0) - where - v2t = v2txs xs - v2txs = value2term' stop loc - v2t' x f = v2txs (x:xs) (bind f (gen xs)) - - var j - | j [i] - PAs i p -> i:allPattVars p - _ -> collectPattOp allPattVars p - ---- -ix loc fn xs i = - if i return True + VCApp (mn,i) [] | mn == cPredef && i == cPFalse -> return False + _ -> verror "Bool" v instance Predef String where toValue = string diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs index 7eb0c3bfb..c3fb83b4b 100644 --- a/src/compiler/GF/Compile/Compute/Value.hs +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -12,8 +12,8 @@ data Value | VGen Int [Value] -- for lambda bound variables, possibly applied | VMeta MetaId Env [Value] -- -- | VClosure Env Term -- used in Typecheck.ConcreteNew - | VAbs BindType Ident Binding -- used in Compute.ConcreteNew - | VProd BindType Value Ident Binding -- used in Compute.ConcreteNew + | VAbs BindType Ident Binding -- used in Compute.Concrete + | VProd BindType Value Ident Binding -- used in Compute.Concrete | VInt Int | VFloat Double | VString String @@ -47,10 +47,10 @@ type Env = [(Ident,Value)] -- | Predefined functions data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper - | ToLower | IsUpper | Length | Plus | EqInt | LessInt + | ToLower | IsUpper | Length | Plus | EqInt | LessInt {- | Show | Read | ToStr | MapStr | EqVal -} | Error | Trace -- Canonical values below: - | PBool | PFalse | PTrue | Int | Float | Ints | NonExist + | PBool | PFalse | PTrue | Int | Float | Ints | NonExist | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT deriving (Show,Eq,Ord,Ix,Bounded,Enum) diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index d74fcdacd..c9f0438e6 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -7,7 +7,7 @@ import GF.Text.Pretty --import GF.Grammar.Predef(cPredef,cInts) --import GF.Compile.Compute.Predef(predef) --import GF.Compile.Compute.Value(Predefined(..)) -import GF.Infra.Ident(Ident,identS,identW,prefixIdent) +import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS) import GF.Infra.Option import GF.Haskell as H import GF.Grammar.Canonical as C @@ -21,7 +21,7 @@ concretes2haskell opts absname gr = | let Grammar abstr cncs = grammar2canonical opts absname gr, cncmod<-cncs, let ModId name = concName cncmod - filename = name ++ ".hs" :: FilePath + filename = showRawIdent name ++ ".hs" :: FilePath ] -- | Generate Haskell code for the given concrete module. @@ -53,7 +53,7 @@ concrete2haskell opts labels = S.difference (S.unions (map S.fromList recs)) common_labels common_records = S.fromList [[label_s]] common_labels = S.fromList [label_s] - label_s = LabelId "s" + label_s = LabelId (rawIdentS "s") signature (CatDef c _) = TypeSig lf (Fun abs (pure lin)) where @@ -69,7 +69,7 @@ concrete2haskell opts where --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs] allcats = S.fromList [c | CatDef c _<-cats] - + gId :: ToIdent i => i -> Ident gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G") . toIdent @@ -116,7 +116,7 @@ concrete2haskell opts where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs] StrType -> tcon0 (identS "Str") TableType pt lt -> Fun (ppT pt) (ppT lt) --- TupleType lts -> +-- TupleType lts -> lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t) @@ -126,7 +126,7 @@ concrete2haskell opts linDefs = map eqn . sortOn fst . map linDef where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs) - linDef (LinDef f xs rhs0) = + linDef (LinDef f xs rhs0) = (cat,(linfunName cat,(lhs,rhs))) where lhs = [ConP (aId f) (map VarP abs_args)] @@ -144,7 +144,7 @@ concrete2haskell opts where vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args] env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)] - + letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) = (a,Ap (Var (linfunName acat)) (Var (abs_arg a))) @@ -187,7 +187,7 @@ concrete2haskell opts pId p@(ParamId s) = if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack - + table cs = if all (null.patVars) ps then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts']) @@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where -- | Record subtyping is converted into explicit coercions in Haskell coerce env ty t = - case (ty,t) of + case (ty,t) of (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts) (TableType ti tv,TableValue _ cs) -> TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs] (RecordType rt,RecordValue r) -> RecordValue [RecordRow l (coerce env ft f) | - RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]] + RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]] (RecordType rt,VarValue x)-> case lookup x env of Just ty' | ty'/=ty -> -- better to compare to normal form of ty' @@ -334,18 +334,17 @@ coerce env ty t = _ -> t where app f ts = ParamConstant (Param f ts) -- !! a hack - to_rcon = ParamId . Unqual . to_rcon' . labels + to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels patVars p = [] -labels r = [l|RecordRow l _<-r] +labels r = [l | RecordRow l _ <- r] proj = Var . identS . proj' -proj' (LabelId l) = "proj_"++l +proj' (LabelId l) = "proj_" ++ showRawIdent l rcon = Var . rcon' rcon' = identS . rcon_name -rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls]) - +rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls]) to_rcon' = ("to_"++) . rcon_name recordType ls = @@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c) class ToIdent i where toIdent :: i -> Ident -instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q -instance ToIdent PredefId where toIdent (PredefId s) = identS s -instance ToIdent CatId where toIdent (CatId s) = identS s -instance ToIdent C.FunId where toIdent (FunId s) = identS s -instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q +instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q +instance ToIdent PredefId where toIdent (PredefId s) = identC s +instance ToIdent CatId where toIdent (CatId s) = identC s +instance ToIdent C.FunId where toIdent (FunId s) = identC s +instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q -qIdentS = identS . unqual +qIdentC = identS . unqual -unqual (Qual (ModId m) n) = m++"_"++n -unqual (Unqual n) = n +unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n +unqual (Unqual n) = showRawIdent n instance ToIdent VarId where toIdent Anonymous = identW - toIdent (VarId s) = identS s + toIdent (VarId s) = identC s diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index ab6476b31..8383f0624 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -25,7 +25,7 @@ import GF.Data.BacktrackM import GF.Data.Operations import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE, import GF.Data.Utilities (updateNthM) --updateNth -import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) +import GF.Compile.Compute.Concrete(normalForm,resourceValues) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List @@ -82,7 +82,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont (goB b1 CNil []) (pres,pargs) pmcfg = getPMCFG pmcfgEnv1 - + stats = let PMCFG prods funs = pmcfg (s,e) = bounds funs !prods_cnt = length prods @@ -103,7 +103,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont newArgs = map getFIds newArgs' in addFunction env0 newCat fun newArgs -addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) +addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc1 def)) mref@(Just (L loc2 ref)) mprn @@ -162,7 +162,7 @@ pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat pgfCncCat gr lincat index = let ((_,size),schema) = computeCatRange gr lincat in PGF.CncCat index (index+size-1) - (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) + (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) (getStrPaths schema))) where getStrPaths :: Schema Identity s c -> [Path] @@ -243,7 +243,7 @@ choices nr path = do (args,_) <- get | (value,index) <- values]) descend schema path rpath = bug $ "descend "++show (schema,path,rpath) - updateEnv path value gr c (args,seq) = + updateEnv path value gr c (args,seq) = case updateNthM (restrictProtoFCat path value) nr args of Just args -> c value (args,seq) Nothing -> bug "conflict in updateEnv" @@ -606,7 +606,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do Just index -> return (CPar (m,[(v,index)])) Nothing -> mzero addConstraint CNil v (CStr _) = bug "restrictProtoFCat: string path" - + update k0 f [] = return [] update k0 f (x@(k,Identity v):xs) | k0 == k = do v <- f v diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 33f35ad08..b0e356bc5 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -6,30 +6,35 @@ module GF.Compile.GrammarToCanonical( ) where import Data.List(nub,partition) import qualified Data.Map as M +import Data.Maybe(fromMaybe) import qualified Data.Set as S import GF.Data.ErrM import GF.Text.Pretty -import GF.Grammar.Grammar +import GF.Grammar.Grammar as G import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues) -import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt) +import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec) import GF.Grammar.Lockfield(isLockLabel) import GF.Grammar.Predef(cPredef,cInts) import GF.Compile.Compute.Predef(predef) import GF.Compile.Compute.Value(Predefined(..)) -import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) -import GF.Infra.Option(optionsPGF) +import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent) +import GF.Infra.Option(Options,optionsPGF) import PGF.Internal(Literal(..)) -import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) +import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues) import GF.Grammar.Canonical as C -import Debug.Trace +import System.FilePath ((), (<.>)) +import qualified Debug.Trace as T + -- | Generate Canonical code for the named abstract syntax and all associated -- concrete syntaxes +grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar grammar2canonical opts absname gr = Grammar (abstract2canonical absname gr) (map snd (concretes2canonical opts absname gr)) -- | Generate Canonical code for the named abstract syntax +abstract2canonical :: ModuleName -> G.Grammar -> Abstract abstract2canonical absname gr = Abstract (modId absname) (convFlags gr absname) cats funs where @@ -44,6 +49,7 @@ abstract2canonical absname gr = convHypo (bt,name,t) = case typeForm t of ([],(_,cat),[]) -> gId cat -- !! + tf -> error $ "abstract2canonical convHypo: " ++ show tf convType t = case typeForm t of @@ -54,25 +60,26 @@ abstract2canonical absname gr = convHypo' (bt,name,t) = TypeBinding (gId name) (convType t) - -- | Generate Canonical code for the all concrete syntaxes associated with -- the named abstract syntax in given the grammar. +concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)] concretes2canonical opts absname gr = [(cncname,concrete2canonical gr cenv absname cnc cncmod) | let cenv = resourceValues opts gr, cnc<-allConcretes gr absname, - let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath + let cncname = "canonical" render cnc <.> "gf" Ok cncmod = lookupModule gr cnc ] -- | Generate Canonical GF for the given concrete module. +concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete concrete2canonical gr cenv absname cnc modinfo = Concrete (modId cnc) (modId absname) (convFlags gr cnc) (neededParamTypes S.empty (params defs)) - [lincat|(_,Left lincat)<-defs] - [lin|(_,Right lin)<-defs] + [lincat | (_,Left lincat) <- defs] + [lin | (_,Right lin) <- defs] where - defs = concatMap (toCanonical gr absname cenv) . + defs = concatMap (toCanonical gr absname cenv) . M.toList $ jments modinfo @@ -85,6 +92,7 @@ concrete2canonical gr cenv absname cnc modinfo = else let ((got,need),def) = paramType gr q in def++neededParamTypes (S.union got have) (S.toList need++qs) +toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)] toCanonical gr absname cenv (name,jment) = case jment of CncCat (Just (L loc typ)) _ _ pprn _ -> @@ -97,7 +105,8 @@ toCanonical gr absname cenv (name,jment) = where tts = tableTypes gr [e'] - e' = unAbs (length params) $ + e' = cleanupRecordFields lincat $ + unAbs (length params) $ nf loc (mkAbs params (mkApp def (map Vr args))) params = [(b,x)|(b,x,_)<-ctx] args = map snd params @@ -108,12 +117,12 @@ toCanonical gr absname cenv (name,jment) = _ -> [] where nf loc = normalForm cenv (L loc name) --- aId n = prefixIdent "A." (gId n) unAbs 0 t = t unAbs n (Abs _ _ t) = unAbs (n-1) t unAbs _ t = t +tableTypes :: G.Grammar -> [Term] -> S.Set QIdent tableTypes gr ts = S.unions (map tabtys ts) where tabtys t = @@ -122,6 +131,7 @@ tableTypes gr ts = S.unions (map tabtys ts) T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs)) _ -> collectOp tabtys t +paramTypes :: G.Grammar -> G.Type -> S.Set QIdent paramTypes gr t = case t of RecType fs -> S.unions (map (paramTypes gr.snd) fs) @@ -140,11 +150,26 @@ paramTypes gr t = Ok (_,ResParam {}) -> S.singleton q _ -> ignore - ignore = trace ("Ignore: "++show t) S.empty + ignore = T.trace ("Ignore: " ++ show t) S.empty +-- | Filter out record fields from definitions which don't appear in lincat. +cleanupRecordFields :: G.Type -> Term -> Term +cleanupRecordFields (RecType ls) (R as) = + let defnFields = M.fromList ls + in R + [ (lbl, (mty, t')) + | (lbl, (mty, t)) <- as + , M.member lbl defnFields + , let Just ty = M.lookup lbl defnFields + , let t' = cleanupRecordFields ty t + ] +cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t +cleanupRecordFields _ t = t +convert :: G.Grammar -> Term -> LinValue convert gr = convert' gr [] +convert' :: G.Grammar -> [Ident] -> Term -> LinValue convert' gr vs = ppT where ppT0 = convert' gr vs @@ -162,20 +187,20 @@ convert' gr vs = ppT S t p -> selection (ppT t) (ppT p) C t1 t2 -> concatValue (ppT t1) (ppT t2) App f a -> ap (ppT f) (ppT a) - R r -> RecordValue (fields r) + R r -> RecordValue (fields (sortRec r)) P t l -> projection (ppT t) (lblId l) Vr x -> VarValue (gId x) Cn x -> VarValue (gId x) -- hmm Con c -> ParamConstant (Param (gId c) []) Sort k -> VarValue (gId k) EInt n -> LiteralValue (IntConstant n) - Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n)) - QC (m,n) -> ParamConstant (Param ((gQId m n)) []) + Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n) + QC (m,n) -> ParamConstant (Param (gQId m n) []) K s -> LiteralValue (StrConstant s) Empty -> LiteralValue (StrConstant "") FV ts -> VariantValue (map ppT ts) Alts t' vs -> alts vs (ppT t') - _ -> error $ "convert' "++show t + _ -> error $ "convert' ppT: " ++ show t ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t) @@ -188,12 +213,12 @@ convert' gr vs = ppT Ok ALL_CAPIT -> p "ALL_CAPIT" _ -> VarValue (gQId cPredef n) -- hmm where - p = PredefValue . PredefId - + p = PredefValue . PredefId . rawIdentS + ppP p = case p of PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) - PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps)) + PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps)) PR r -> RecordPattern (fields r) {- PW -> WildPattern PV x -> VarP x @@ -202,6 +227,7 @@ convert' gr vs = ppT PFloat x -> Lit (show x) PT _ p -> ppP p PAs x p -> AsP x (ppP p) -} + _ -> error $ "convert' ppP: " ++ show p where fields = map field . filter (not.isLockLabel.fst) field (l,p) = RecordRow (lblId l) (ppP p) @@ -218,12 +244,12 @@ convert' gr vs = ppT pre Empty = [""] -- Empty == K "" pre (Strs ts) = concatMap pre ts pre (EPatt p) = pat p - pre t = error $ "pre "++show t + pre t = error $ "convert' alts pre: " ++ show t pat (PString s) = [s] pat (PAlt p1 p2) = pat p1++pat p2 pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2] - pat p = error $ "pat "++show p + pat p = error $ "convert' alts pat: "++show p fields = map field . filter (not.isLockLabel.fst) field (l,(_,t)) = RecordRow (lblId l) (ppT t) @@ -236,6 +262,7 @@ convert' gr vs = ppT ParamConstant (Param p (ps++[a])) _ -> error $ "convert' ap: "++render (ppA f <+> ppA a) +concatValue :: LinValue -> LinValue -> LinValue concatValue v1 v2 = case (v1,v2) of (LiteralValue (StrConstant ""),_) -> v2 @@ -243,21 +270,24 @@ concatValue v1 v2 = _ -> ConcatValue v1 v2 -- | Smart constructor for projections -projection r l = maybe (Projection r l) id (proj r l) +projection :: LinValue -> LabelId -> LinValue +projection r l = fromMaybe (Projection r l) (proj r l) +proj :: LinValue -> LabelId -> Maybe LinValue proj r l = case r of - RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of + RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of [v] -> Just v _ -> Nothing _ -> Nothing -- | Smart constructor for selections +selection :: LinValue -> LinValue -> LinValue selection t v = -- Note: impossible cases can become possible after grammar transformation case t of TableValue tt r -> - case nub [rv|TableRow _ rv<-keep] of + case nub [rv | TableRow _ rv <- keep] of [rv] -> rv _ -> Selection (TableValue tt r') v where @@ -276,13 +306,16 @@ selection t v = (keep,discard) = partition (mightMatchRow v) r _ -> Selection t v +impossible :: LinValue -> LinValue impossible = CommentedValue "impossible" +mightMatchRow :: LinValue -> TableRow rhs -> Bool mightMatchRow v (TableRow p _) = case p of WildPattern -> True _ -> mightMatch v p +mightMatch :: LinValue -> LinPattern -> Bool mightMatch v p = case v of ConcatValue _ _ -> False @@ -294,16 +327,18 @@ mightMatch v p = RecordValue rv -> case p of RecordPattern rp -> - and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp] + and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp] _ -> False _ -> True +patVars :: Patt -> [Ident] patVars p = case p of PV x -> [x] PAs x p -> x:patVars p _ -> collectPattOp patVars p +convType :: Term -> LinType convType = ppT where ppT t = @@ -315,9 +350,9 @@ convType = ppT Sort k -> convSort k -- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal FV (t:ts) -> ppT t -- !! - QC (m,n) -> ParamType (ParamTypeId ((gQId m n))) - Q (m,n) -> ParamType (ParamTypeId ((gQId m n))) - _ -> error $ "Missing case in convType for: "++show t + QC (m,n) -> ParamType (ParamTypeId (gQId m n)) + Q (m,n) -> ParamType (ParamTypeId (gQId m n)) + _ -> error $ "convType ppT: " ++ show t convFields = map convField . filter (not.isLockLabel.fst) convField (l,r) = RecordRow (lblId l) (ppT r) @@ -326,15 +361,20 @@ convType = ppT "Float" -> FloatType "Int" -> IntType "Str" -> StrType - _ -> error ("convSort "++show k) + _ -> error $ "convType convSort: " ++ show k +toParamType :: Term -> ParamType toParamType t = case convType t of ParamType pt -> pt - _ -> error ("toParamType "++show t) + _ -> error $ "toParamType: " ++ show t +toParamId :: Term -> ParamId toParamId t = case toParamType t of ParamTypeId p -> p +paramType :: G.Grammar + -> (ModuleName, Ident) + -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef]) paramType gr q@(_,n) = case lookupOrigInfo gr q of Ok (m,ResParam (Just (L _ ps)) _) @@ -342,7 +382,7 @@ paramType gr q@(_,n) = ((S.singleton (m,n),argTypes ps), [ParamDef name (map (param m) ps)] ) - where name = (gQId m n) + where name = gQId m n Ok (m,ResOper _ (Just (L _ t))) | m==cPredef && n==cInts -> ((S.empty,S.empty),[]) {- @@ -350,36 +390,46 @@ paramType gr q@(_,n) = [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-} | otherwise -> ((S.singleton (m,n),paramTypes gr t), - [ParamAliasDef ((gQId m n)) (convType t)]) + [ParamAliasDef (gQId m n) (convType t)]) _ -> ((S.empty,S.empty),[]) where - param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx] + param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx] argTypes = S.unions . map argTypes1 argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] -lblId = LabelId . render -- hmm -modId (MN m) = ModId (showIdent m) +lblId :: Label -> C.LabelId +lblId (LIdent ri) = LabelId ri +lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm -class FromIdent i where gId :: Ident -> i +modId :: ModuleName -> C.ModId +modId (MN m) = ModId (ident2raw m) + +class FromIdent i where + gId :: Ident -> i instance FromIdent VarId where - gId i = if isWildIdent i then Anonymous else VarId (showIdent i) + gId i = if isWildIdent i then Anonymous else VarId (ident2raw i) -instance FromIdent C.FunId where gId = C.FunId . showIdent -instance FromIdent CatId where gId = CatId . showIdent +instance FromIdent C.FunId where gId = C.FunId . ident2raw +instance FromIdent CatId where gId = CatId . ident2raw instance FromIdent ParamId where gId = ParamId . unqual instance FromIdent VarValueId where gId = VarValueId . unqual -class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i +class FromIdent i => QualIdent i where + gQId :: ModuleName -> Ident -> i -instance QualIdent ParamId where gQId m n = ParamId (qual m n) +instance QualIdent ParamId where gQId m n = ParamId (qual m n) instance QualIdent VarValueId where gQId m n = VarValueId (qual m n) -qual m n = Qual (modId m) (showIdent n) -unqual n = Unqual (showIdent n) +qual :: ModuleName -> Ident -> QualId +qual m n = Qual (modId m) (ident2raw n) +unqual :: Ident -> QualId +unqual n = Unqual (ident2raw n) + +convFlags :: G.Grammar -> ModuleName -> Flags convFlags gr mn = - Flags [(n,convLit v) | + Flags [(rawIdentS n,convLit v) | (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)] where convLit l = diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 393deb020..ac3fa357c 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -6,7 +6,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/16 13:56:13 $ +-- > CVS $Date: 2005/09/16 13:56:13 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.18 $ -- @@ -21,7 +21,7 @@ import GF.Grammar.Printer import GF.Grammar.Macros import GF.Grammar.Lookup import GF.Grammar.Predef -import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues) +import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues) import GF.Data.Operations import GF.Infra.Option @@ -90,7 +90,7 @@ evalInfo opts resenv sgr m c info = do let ppr' = fmap (evalPrintname resenv c) ppr return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed {- - ResOper pty pde + ResOper pty pde | not new && OptExpand `Set.member` optim -> do pde' <- case pde of Just (L loc de) -> do de <- computeConcrete gr de @@ -171,13 +171,13 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ _ -> Bad (render ("linearization type field cannot be" <+> typ)) mkLinReference :: SourceGrammar -> Type -> Err Term -mkLinReference gr typ = - liftM (Abs Explicit varStr) $ +mkLinReference gr typ = + liftM (Abs Explicit varStr) $ case mkDefField typ (Vr varStr) of Bad "no string" -> return Empty x -> x where - mkDefField ty trm = + mkDefField ty trm = case ty of Table pty ty -> do ps <- allParamValues gr pty case ps of @@ -203,7 +203,7 @@ factor param c i t = T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs] _ -> composSafeOp (factor param c i) t where - factors ty pvs0 + factors ty pvs0 | not param = V ty (map snd pvs0) factors ty [] = V ty [] factors ty pvs0@[(p,v)] = V ty [v] @@ -224,7 +224,7 @@ factor param c i t = replace :: Term -> Term -> Term -> Term replace old new trm = case trm of - -- these are the important cases, since they can correspond to patterns + -- these are the important cases, since they can correspond to patterns QC _ | trm == old -> new App _ _ | trm == old -> new R _ | trm == old -> new diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index 6356c9f6d..bc8e59f57 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/06/17 12:39:07 $ +-- > CVS $Date: 2005/06/17 12:39:07 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.8 $ -- @@ -22,7 +22,7 @@ import PGF.Internal import GF.Data.Operations import GF.Infra.Option -import Data.List --(isPrefixOf, find, intersperse) +import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy) import qualified Data.Map as Map type Prefix = String -> String @@ -34,11 +34,12 @@ grammar2haskell :: Options -> PGF -> String grammar2haskell opts name gr = foldr (++++) [] $ - pragmas ++ haskPreamble gadt name derivingClause extraImports ++ + pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++ [types, gfinstances gId lexical gr'] ++ compos where gr' = hSkeleton gr gadt = haskellOption opts HaskellGADT dataExt = haskellOption opts HaskellData + pgf2 = haskellOption opts HaskellPGF2 lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars | otherwise = ("G"++) . rmForbiddenChars @@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $ derivingClause | dataExt = "deriving (Show,Data)" | otherwise = "deriving Show" - extraImports | gadt = ["import Control.Monad.Identity", - "import Data.Monoid"] + extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"] | dataExt = ["import Data.Data"] | otherwise = [] + pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"] + | otherwise = ["import PGF hiding (Tree)"] types | gadt = datatypesGADT gId lexical gr' | otherwise = datatypes gId derivingClause lexical gr' compos | gadt = prCompos gId lexical gr' ++ composClass | otherwise = [] -haskPreamble gadt name derivingClause extraImports = +haskPreamble :: Bool -> String -> String -> [String] -> [String] +haskPreamble gadt name derivingClause imports = [ "module " ++ name ++ " where", "" - ] ++ extraImports ++ [ - "import PGF hiding (Tree)", + ] ++ imports ++ [ + "", "----------------------------------------------------", "-- automatic translation from GF to Haskell", "----------------------------------------------------", @@ -85,10 +88,11 @@ haskPreamble gadt name derivingClause extraImports = "" ] +predefInst :: Bool -> String -> String -> String -> String -> String -> String predefInst gadt derivingClause gtyp typ destr consr = (if gadt then [] - else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n") + else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n" ) ++ "instance Gf" +++ gtyp +++ "where" ++++ @@ -103,10 +107,10 @@ type OIdent = String type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd +datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g +gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String @@ -131,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)] lexicalConstructor :: OIdent -> String lexicalConstructor cat = "Lex" ++ cat +predefTypeSkel :: HSkeleton predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]] -- GADT version of data types datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String -datatypesGADT gId lexical (_,skel) = unlines $ +datatypesGADT gId lexical (_,skel) = unlines $ concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++ - [ - "", + [ + "", "data Tree :: * -> * where" - ] ++ + ] ++ concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++ [ " GString :: String -> Tree GString_", @@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules) "data"+++gId cat++"_"] hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT gId lexical (cat, rules) +hDatatypeGADT gId lexical (cat, rules) | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- nonLexicalRules (lexical cat) rules ] ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] where t = "Tree" +++ gId cat ++ "_" hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] hEqGADT gId lexical (cat, rules) - | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] + | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules] ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else [] where patt s (f,xs) = unwords (gId f : mkSVars s (length xs)) - eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | + eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"]) listr c = (c,["foo"]) -- foo just for length = 1 listeqs = "and [x == y | (x,y) <- zip x1 y1]" @@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String] prCompos gId lexical (_,catrules) = ["instance Compos Tree where", " compos r a f t = case t of"] - ++ + ++ [" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)), - (f,xs) <- rs, not (null xs)] - ++ + (f,xs) <- rs, not (null xs)] + ++ [" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)] - ++ + ++ [" _ -> r t"] where - prComposCons f xs = let vs = mkVars (length xs) in + prComposCons f xs = let vs = mkVars (length xs) in f +++ unwords vs +++ "->" +++ rhs f (zip vs xs) rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs) - prRec f (v,c) + prRec f (v,c) | isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v | otherwise = "`a`" +++ "f" +++ v - isList f = (gId "List") `isPrefixOf` f + isList f = gId "List" `isPrefixOf` f gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs +hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 hInstance gId _ m (cat,[]) = unlines [ "instance Show" +++ gId cat, @@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [ " gf _ = undefined", " fg _ = undefined" ] -hInstance gId lexical m (cat,rules) +hInstance gId lexical m (cat,rules) | isListCat (cat,rules) = "instance Gf" +++ gId cat +++ "where" ++++ - " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" + " gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])" +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ - " gf (" ++ gId cat +++ "(x:xs)) = " - ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] + " gf (" ++ gId cat +++ "(x:xs)) = " + ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] -- no show for GADTs --- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" +-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" | otherwise = "instance Gf" +++ gId cat +++ "where\n" ++ unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] @@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules) ec = elemCat cat baseVars = mkVars (baseSize (cat,rules)) mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ - (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ + (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ "=" +++ mkRHS f xx' - mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" +mkVars :: Int -> [String] mkVars = mkSVars "x" + +mkSVars :: String -> Int -> [String] mkSVars s n = [s ++ show i | i <- [1..n]] ----fInstance m ("Cn",_) = "" --- fInstance _ _ m (cat,[]) = "" fInstance gId lexical m (cat,rules) = " fg t =" ++++ - (if isList + (if isList then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of" else " case unApp t of") ++++ unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ @@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) = " Just (i," ++ "[" ++ prTList "," xx' ++ "])" +++ "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx' - where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] - mkRHS f vars - | isList = - if "Base" `isPrefixOf` f - then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" - else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1) - | otherwise = - gId f +++ - prTList " " [prParenth ("fg" +++ x) | x <- vars] + where + xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] + mkRHS f vars + | isList = + if "Base" `isPrefixOf` f + then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" + else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1) + | otherwise = + gId f +++ + prTList " " [prParenth ("fg" +++ x) | x <- vars] --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] hSkeleton :: PGF -> (String,HSkeleton) -hSkeleton gr = - (showCId (absname gr), - let fs = - [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | +hSkeleton gr = + (showCId (absname gr), + let fs = + [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | fs@((_, (_,c)):_) <- fns] - in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)] + in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)] ) where - cts = Map.keys (cats (abstract gr)) + cts = Map.keys (cats (abstract gr)) fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) valtyps (_, (_,x)) (_, (_,y)) = compare x y valtypg (_, (_,x)) (_, (_,y)) = x == y @@ -291,9 +301,10 @@ updateSkeleton cat skel rule = -} isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules + && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs + where + c = elemCat cat + fs = map fst rules -- | Gets the element category of a list category. elemCat :: OIdent -> OIdent @@ -310,7 +321,7 @@ baseSize (_,rules) = length bs where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules composClass :: [String] -composClass = +composClass = [ "", "class Compos t where", @@ -337,4 +348,3 @@ composClass = "", "newtype C b a = C { unC :: b }" ] - diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index aacf24c5b..41b2cdc67 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.19 $ -- @@ -23,9 +23,9 @@ ----------------------------------------------------------------------------- module GF.Compile.Rename ( - renameSourceTerm, - renameModule - ) where + renameSourceTerm, + renameModule + ) where import GF.Infra.Ident import GF.Infra.CheckM @@ -39,6 +39,7 @@ import GF.Data.Operations import Control.Monad import Data.List (nub,(\\)) +import qualified Data.List as L import qualified Data.Map as Map import Data.Maybe(mapMaybe) import GF.Text.Pretty @@ -67,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env) -- Fails immediately on error, makes it possible to try other possibilities renameIdentTerm' :: Status -> Term -> Check Term -renameIdentTerm' env@(act,imps) t0 = +renameIdentTerm' env@(act,imps) t0 = case t0 of Vr c -> ident predefAbs c Cn c -> ident (\_ s -> checkError s) c @@ -84,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 = _ -> return t0 where opens = [st | (OSimple _,st) <- imps] - qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ - [(m, st) | (OQualif _ m, st) <- imps] ++ + qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ + [(m, st) | (OQualif _ m, st) <- imps] ++ [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible -- this facility is mainly for BWC with GF1: you need not import PredefAbs @@ -93,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 = | isPredefCat c = return (Q (cPredefAbs,c)) | otherwise = checkError s - ident alt c = + ident alt c = case Map.lookup c act of Just f -> return (f c) _ -> case mapMaybe (Map.lookup c) opens of @@ -105,7 +106,26 @@ renameIdentTerm' env@(act,imps) t0 = ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$ "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$ "given" <+> fsep (punctuate ',' (map fst qualifs))) - return t + return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others. + where + -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56 + -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06 + notFromCommonModule :: Term -> Bool + notFromCommonModule term = + let t = render $ ppTerm Qualified 0 term :: String + in not $ any (\moduleName -> moduleName `L.isPrefixOf` t) + ["CommonX", "ConstructX", "ExtendFunctor" + ,"MarkHTMLX", "ParamX", "TenseX", "TextX"] + + -- If one of the terms comes from the common modules, + -- we choose the other one, because that's defined in the grammar. + bestTerm :: [Term] -> Term + bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_) + bestTerm ts@(t:_) = + let notCommon = [t | t <- ts, notFromCommonModule t] + in case notCommon of + [] -> t -- All terms are from common modules, return first of original list + (u:_) -> u -- ≥1 terms are not from common modules, return first of those info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo info2status mq c i = case i of @@ -137,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo)) self2status :: ModuleName -> ModuleInfo -> StatusMap self2status c m = Map.mapWithKey (info2status (Just c)) (jments m) - + renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info renameInfo cwd status (m,mi) i info = case info of @@ -188,7 +208,7 @@ renameTerm env vars = ren vars where Abs b x t -> liftM (Abs b x) (ren (x:vs) t) Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b) Typed a b -> liftM2 Typed (ren vs a) (ren vs b) - Vr x + Vr x | elem x vs -> return trm | otherwise -> renid trm Cn _ -> renid trm @@ -199,7 +219,7 @@ renameTerm env vars = ren vars where i' <- case i of TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source _ -> return i - liftM (T i') $ mapM (renCase vs) cs + liftM (T i') $ mapM (renCase vs) cs Let (x,(m,a)) b -> do m' <- case m of @@ -209,7 +229,7 @@ renameTerm env vars = ren vars where b' <- ren (x:vs) b return $ Let (x,(m',a')) b' - P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either + P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either -- record projection from variable or constant $r$ or qualified expression with module $r$ | elem r vs -> return trm -- try var proj first .. | otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second. @@ -311,7 +331,7 @@ renamePattern env patt = renameContext :: Status -> Context -> Check Context renameContext b = renc [] where renc vs cont = case cont of - (bt,x,t) : xts + (bt,x,t) : xts | isWildIdent x -> do t' <- ren vs t xts' <- renc vs xts diff --git a/src/compiler/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/GF/Compile/TypeCheck/Abstract.hs index 196e1a646..c76660259 100644 --- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs +++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/15 16:22:02 $ +-- > CVS $Date: 2005/09/15 16:22:02 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.16 $ -- @@ -13,11 +13,11 @@ ----------------------------------------------------------------------------- module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly. - checkContext, - checkTyp, - checkDef, - checkConstrs, - ) where + checkContext, + checkTyp, + checkDef, + checkConstrs, + ) where import GF.Data.Operations @@ -33,8 +33,8 @@ import GF.Text.Pretty --import Control.Monad (foldM, liftM, liftM2) -- | invariant way of creating TCEnv from context -initTCEnv gamma = - (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) +initTCEnv gamma = + (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) -- interface to TC type checker diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 2afff7c6a..e9420290a 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -1,6 +1,7 @@ {-# LANGUAGE PatternGuards #-} -module GF.Compile.TypeCheck.Concrete( {-checkLType, inferLType, computeLType, ppType-} ) where -{- +module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint + import GF.Infra.CheckM import GF.Data.Operations @@ -22,10 +23,16 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed | isPredefConstant ty -> return ty ---- shouldn't be needed - Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do + Q (m,ident) -> checkIn ("module" <+> m) $ do ty' <- lookupResDef gr (m,ident) if ty' == ty then return ty else comp g ty' --- is this necessary to test? + AdHocOverload ts -> do + over <- getOverload gr g (Just typeType) t + case over of + Just (tr,_) -> return tr + _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t) + Vr ident -> checkLookup ident g -- never needed to compute! App f a -> do @@ -62,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t lockRecType c t' ---- locking to be removed AR 20/6/2009 _ | ty == typeTok -> return typeStr - _ | isPredefConstant ty -> return ty _ -> composOp (comp g) ty @@ -73,26 +79,26 @@ inferLType gr g trm = case trm of Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of Just ty -> return ty - Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) + Nothing -> checkError ("unknown in Predef:" <+> ident) Q ident -> checks [ termWith trm $ lookupResType gr ident >>= computeLType gr g , lookupResDef gr ident >>= inferLType gr g , - checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm) + checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm) ] QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of Just ty -> return ty - Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident) + Nothing -> checkError ("unknown in Predef:" <+> ident) QC ident -> checks [ termWith trm $ lookupResType gr ident >>= computeLType gr g , lookupResDef gr ident >>= inferLType gr g , - checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) + checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) ] Vr ident -> termWith trm $ checkLookup ident g @@ -100,7 +106,12 @@ inferLType gr g trm = case trm of Typed e t -> do t' <- computeLType gr g t checkLType gr g e t' - return (e,t') + + AdHocOverload ts -> do + over <- getOverload gr g Nothing trm + case over of + Just trty -> return trty + _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) App f a -> do over <- getOverload gr g Nothing trm @@ -110,13 +121,17 @@ inferLType gr g trm = case trm of (f',fty) <- inferLType gr g f fty' <- computeLType gr g fty case fty' of - Prod bt z arg val -> do + Prod bt z arg val -> do a' <- justCheck g a arg - ty <- if isWildIdent z + ty <- if isWildIdent z then return val else substituteLType [(bt,z,a')] val - return (App f' a',ty) - _ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty) + return (App f' a',ty) + _ -> + let term = ppTerm Unqualified 0 f + funName = pp . head . words .render $ term + in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$ + "\n ** Maybe you gave too many arguments to" <+> funName <+> "\n") S f x -> do (f', fty) <- inferLType gr g f @@ -124,7 +139,7 @@ inferLType gr g trm = case trm of Table arg val -> do x'<- justCheck g x arg return (S f' x', val) - _ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm)) + _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm)) P t i -> do (t',ty) <- inferLType gr g t --- ?? @@ -132,16 +147,16 @@ inferLType gr g trm = case trm of let tr2 = P t' i termWith tr2 $ case ty' of RecType ts -> case lookup i ts of - Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty')) + Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty')) Just x -> return x - _ -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$ - text " instead of the inferred:" <+> ppTerm Unqualified 0 ty') + _ -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$ + " instead of the inferred:" <+> ppTerm Unqualified 0 ty') R r -> do let (ls,fs) = unzip r fsts <- mapM inferM fs let ts = [ty | (Just ty,_) <- fsts] - checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts) + checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts) return $ (R (zip ls fsts), RecType (zip ls ts)) T (TTyped arg) pts -> do @@ -152,10 +167,10 @@ inferLType gr g trm = case trm of checkLType gr g trm (Table arg val) T ti pts -> do -- tries to guess: good in oper type inference let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] - case pts' of - [] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm) ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do + case pts' of + [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm) +---- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] + _ -> do (arg,val) <- checks $ map (inferCase Nothing) pts' checkLType gr g trm (Table arg val) V arg pts -> do @@ -166,9 +181,9 @@ inferLType gr g trm = case trm of K s -> do if elem ' ' s then do - let ss = foldr C Empty (map K (words s)) + let ss = foldr C Empty (map K (words s)) ----- removed irritating warning AR 24/5/2008 - ----- checkWarn ("token \"" ++ s ++ + ----- checkWarn ("token \"" ++ s ++ ----- "\" converted to token list" ++ prt ss) return (ss, typeStr) else return (trm, typeStr) @@ -179,50 +194,56 @@ inferLType gr g trm = case trm of Empty -> return (trm, typeStr) - C s1 s2 -> + C s1 s2 -> check2 (flip (justCheck g) typeStr) C s1 s2 typeStr - Glue s1 s2 -> + Glue s1 s2 -> check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok ---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 Strs (Cn c : ts) | c == cConflict -> do - checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts)) + checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts)) inferLType gr g (head ts) Strs ts -> do - ts' <- mapM (\t -> justCheck g t typeStr) ts + ts' <- mapM (\t -> justCheck g t typeStr) ts return (Strs ts', typeStrs) Alts t aa -> do t' <- justCheck g t typeStr aa' <- flip mapM aa (\ (c,v) -> do - c' <- justCheck g c typeStr + c' <- justCheck g c typeStr v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr] return (c',v')) return (Alts t' aa', typeStr) RecType r -> do let (ls,ts) = unzip r - ts' <- mapM (flip (justCheck g) typeType) ts + ts' <- mapM (flip (justCheck g) typeType) ts return (RecType (zip ls ts'), typeType) ExtR r s -> do - (r',rT) <- inferLType gr g r + +--- over <- getOverload gr g Nothing r +--- let r1 = maybe r fst over + let r1 = r --- + + (r',rT) <- inferLType gr g r1 rT' <- computeLType gr g rT + (s',sT) <- inferLType gr g s sT' <- computeLType gr g sT let trm' = ExtR r' s' - ---- trm' <- plusRecord r' s' case (rT', sT') of (RecType rs, RecType ss) -> do - rt <- plusRecType rT' sT' + let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields checkLType gr g trm' rt ---- return (trm', rt) - _ | rT' == typeType && sT' == typeType -> return (trm', typeType) - _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm) + _ | rT' == typeType && sT' == typeType -> do + return (trm', typeType) + _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm) - Sort _ -> + Sort _ -> termWith trm $ return typeType Prod bt x a b -> do @@ -231,7 +252,7 @@ inferLType gr g trm = case trm of return (Prod bt x a' b', typeType) Table p t -> do - p' <- justCheck g p typeType --- check p partype! + p' <- justCheck g p typeType --- check p partype! t' <- justCheck g t typeType return $ (Table p' t', typeType) @@ -250,9 +271,9 @@ inferLType gr g trm = case trm of ELin c trm -> do (trm',ty) <- inferLType gr g trm ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 - return $ (ELin c trm', ty') + return $ (ELin c trm', ty') - _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm) + _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm) where isPredef m = elem m [cPredef,cPredefAbs] @@ -299,7 +320,6 @@ inferLType gr g trm = case trm of PChars _ -> return $ typeStr _ -> inferLType gr g (patt2term p) >>= return . snd - -- type inference: Nothing, type checking: Just t -- the latter permits matching with value type getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type)) @@ -310,15 +330,28 @@ getOverload gr g mt ot = case appForm ot of v <- matchOverload f typs ttys return $ Just v _ -> return Nothing + (AdHocOverload cs@(f:_), ts) -> do --- the function name f is only used in error messages + let typs = concatMap collectOverloads cs + ttys <- mapM (inferLType gr g) ts + v <- matchOverload f typs ttys + return $ Just v _ -> return Nothing + where + collectOverloads tr@(Q c) = case lookupOverload gr c of + Ok typs -> typs + _ -> case lookupResType gr c of + Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))] + _ -> [] + collectOverloads _ = [] --- constructors QC + matchOverload f typs ttys = do let (tts,tys) = unzip ttys let vfs = lookupOverloadInstance tys typs let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v] let showTypes ty = hsep (map ppType ty) - + let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs]) -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013 @@ -329,50 +362,57 @@ getOverload gr g mt ot = case appForm ot of case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of ([(_,val,fun)],_) -> return (mkApp fun tts, val) ([],[(pre,val,fun)]) -> do - checkWarn $ text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$ - text "for" $$ + checkWarn $ "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$ + "for" $$ nest 2 (showTypes tys) $$ - text "using" $$ + "using" $$ nest 2 (showTypes pre) return (mkApp fun tts, val) ([],[]) -> do - checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$ - text "for" $$ + checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$ + maybe empty (\x -> "with value type" <+> ppType x) mt $$ + "for argument list" $$ nest 2 stysError $$ - text "among" $$ - nest 2 (vcat stypsError) $$ - maybe empty (\x -> text "with value type" <+> ppType x) mt + "among alternatives" $$ + nest 2 (vcat stypsError) + (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of ([(val,fun)],_) -> do return (mkApp fun tts, val) ([],[(val,fun)]) -> do - checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) + checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) return (mkApp fun tts, val) ----- unsafely exclude irritating warning AR 24/5/2008 ------ checkWarn $ "overloading of" +++ prt f +++ +----- checkWarn $ "overloading of" +++ prt f +++ ----- "resolved by excluding partial applications:" ++++ ----- unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - - _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+> - text "for" <+> hsep (map ppType tys) $$ - text "with alternatives" $$ - nest 2 (vcat [ppType ty | (_,ty,_) <- if null vfs1 then vfs2 else vfs2]) +--- now forgiving ambiguity with a warning AR 1/2/2014 +-- This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before. +-- But it also gives a chance to ambiguous overloadings that were banned before. + (nps1,nps2) -> do + checkWarn $ "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+> + ---- "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$ + "resolved by selecting the first of the alternatives" $$ + nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []]) + case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of + [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f + h:_ -> return h matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)] unlocked v = case v of - RecType fs -> RecType $ filter (not . isLockLabel . fst) fs + RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs) _ -> v ---- TODO: accept subtypes ---- TODO: use a trie - lookupOverloadInstance tys typs = - [((pre,mkFunType rest val, t),isExact) | + lookupOverloadInstance tys typs = + [((pre,mkFunType rest val, t),isExact) | let lt = length tys, (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, + let (pre,rest) = splitAt lt ty, let isExact = pre == tys, isExact || map unlocked pre == map unlocked tys ] @@ -385,20 +425,21 @@ getOverload gr g mt ot = case appForm ot of checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type) checkLType gr g trm typ0 = do - typ <- computeLType gr g typ0 case trm of Abs bt x c -> do case typ of - Prod bt' z a b -> do + Prod bt' z a b -> do (c',b') <- if isWildIdent z then checkLType gr ((bt,x,a):g) c b - else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b + else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b checkLType gr ((bt,x,a):g) c b' - return $ (Abs bt x c', Prod bt' x a b') - _ -> checkError $ text "function type expected instead of" <+> ppType typ + return $ (Abs bt x c', Prod bt' z a b') + _ -> checkError $ "function type expected instead of" <+> ppType typ $$ + "\n ** Double-check that the type signature of the operation" $$ + "matches the number of arguments given to it.\n" App f a -> do over <- getOverload gr g (Just typ) trm @@ -408,6 +449,12 @@ checkLType gr g trm typ0 = do (trm',ty') <- inferLType gr g trm termWith trm' $ checkEqLType gr g typ ty' trm' + AdHocOverload ts -> do + over <- getOverload gr g Nothing trm + case over of + Just trty -> return trty + _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) + Q _ -> do over <- getOverload gr g (Just typ) trm case over of @@ -417,21 +464,21 @@ checkLType gr g trm typ0 = do termWith trm' $ checkEqLType gr g typ ty' trm' T _ [] -> - checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ) - T _ cs -> case typ of - Table arg val -> do + checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ) + T _ cs -> case typ of + Table arg val -> do case allParamValues gr arg of Ok vs -> do let ps0 = map fst cs ps <- testOvershadow ps0 vs - if null ps - then return () - else checkWarn (text "patterns never reached:" $$ + if null ps + then return () + else checkWarn ("patterns never reached:" $$ nest 2 (vcat (map (ppPatt Unqualified 0) ps))) _ -> return () -- happens with variable types cs' <- mapM (checkCase arg val) cs return (T (TTyped arg) cs', typ) - _ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType typ) + _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ) V arg0 vs -> case typ of Table arg1 val -> @@ -439,51 +486,54 @@ checkLType gr g trm typ0 = do vs1 <- allParamValues gr arg1 if length vs1 == length vs then return () - else checkError $ text "wrong number of values in table" <+> ppTerm Unqualified 0 trm + else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs] return (V arg' vs',typ) R r -> case typ of --- why needed? because inference may be too difficult RecType rr -> do - let (ls,_) = unzip rr -- labels of expected type + --let (ls,_) = unzip rr -- labels of expected type fsts <- mapM (checkM r) rr -- check that they are found in the record return $ (R fsts, typ) -- normalize record - _ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ)) + _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ)) ExtR r s -> case typ of _ | typ == typeType -> do trm' <- computeLType gr g trm case trm' of - RecType _ -> termWith trm $ return typeType - ExtR (Vr _) (RecType _) -> termWith trm $ return typeType + RecType _ -> termWith trm' $ return typeType + ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType -- ext t = t ** ... - _ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm)) + _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm)) RecType rr -> do - (r',ty,s') <- checks [ - do (r',ty) <- inferLType gr g r - return (r',ty,s) - , - do (s',ty) <- inferLType gr g s - return (s',ty,r) - ] - case ty of - RecType rr1 -> do - let (rr0,rr2) = recParts rr rr1 - r2 <- justCheck g r' rr0 - s2 <- justCheck g s' rr2 - return $ (ExtR r2 s2, typ) - _ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$ - text "but found" <+> ppTerm Unqualified 0 ty) + ll2 <- case s of + R ss -> return $ map fst ss + _ -> do + (s',typ2) <- inferLType gr g s + case typ2 of + RecType ss -> return $ map fst ss + _ -> checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2)) + let ll1 = [l | (l,_) <- rr, notElem l ll2] + +--- over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020 +--- let r1 = maybe r fst over + let r1 = r --- + + (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1]) + (s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2]) + + let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2]) + return (rec, typ) ExtR ty ex -> do r' <- justCheck g r ty s' <- justCheck g s ex return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ - _ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ) + _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ) FV vs -> do ttys <- mapM (flip (checkLType gr g) typ) vs @@ -498,7 +548,7 @@ checkLType gr g trm typ0 = do (arg',val) <- checkLType gr g arg p checkEqLType gr g typ t trm return (S tab' arg', t) - _ -> checkError (text "table type expected for applied table instead of" <+> ppType ty') + _ -> checkError ("table type expected for applied table instead of" <+> ppType ty') , do (arg',ty) <- inferLType gr g arg ty' <- computeLType gr g ty @@ -507,7 +557,8 @@ checkLType gr g trm typ0 = do ] Let (x,(mty,def)) body -> case mty of Just ty -> do - (def',ty') <- checkLType gr g def ty + (ty0,_) <- checkLType gr g ty typeType + (def',ty') <- checkLType gr g def ty0 body' <- justCheck ((Explicit,x,ty'):g) body typ return (Let (x,(Just ty',def')) body', typ) _ -> do @@ -523,10 +574,10 @@ checkLType gr g trm typ0 = do termWith trm' $ checkEqLType gr g typ ty' trm' where justCheck g ty te = checkLType gr g ty te >>= return . fst - - recParts rr t = (RecType rr1,RecType rr2) where - (rr1,rr2) = partition (flip elem (map fst t) . fst) rr - +{- + recParts rr t = (RecType rr1,RecType rr2) where + (rr1,rr2) = partition (flip elem (map fst t) . fst) rr +-} checkM rms (l,ty) = case lookup l rms of Just (Just ty0,t) -> do checkEqLType gr g ty ty0 t @@ -535,12 +586,12 @@ checkLType gr g trm typ0 = do Just (_,t) -> do (t',ty') <- checkLType gr g t ty return (l,(Just ty',t')) - _ -> checkError $ - if isLockLabel l + _ -> checkError $ + if isLockLabel l then let cat = drop 5 (showIdent (label2ident l)) - in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <> - text "; try wrapping it with lin" <+> text cat - else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms) + in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <> + "; try wrapping it with lin" <+> cat + else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms) checkCase arg val (p,t) = do cont <- pattContext gr g arg p @@ -553,7 +604,7 @@ pattContext env g typ p = case p of PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 t <- lookupResType env (q,c) let (cont,v) = typeFormCnc t - checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) + checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) (length cont == length ps) checkEqLType env g typ v (patt2term p) mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat @@ -564,7 +615,7 @@ pattContext env g typ p = case p of let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] ----- checkWarn $ prt p ++++ show pts ----- debug mapM (uncurry (pattContext env g)) pts >>= return . concat - _ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ') + _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ') PT t p' -> do checkEqLType env g typ t (patt2term p') pattContext env g typ p' @@ -577,10 +628,10 @@ pattContext env g typ p = case p of g1 <- pattContext env g typ p' g2 <- pattContext env g typ q let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1]) - checkCond - (text "incompatible bindings of" <+> - fsep (map ppIdent pts) <+> - text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) + checkCond + ("incompatible bindings of" <+> + fsep pts <+> + "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) return g1 -- must be g1 == g2 PSeq p q -> do g1 <- pattContext env g typ p @@ -590,11 +641,11 @@ pattContext env g typ p = case p of PNeg p' -> noBind typ p' _ -> return [] ---- check types! - where + where noBind typ p' = do co <- pattContext env g typ p' if not (null co) - then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p) + then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p) >> return [] else return [] @@ -603,9 +654,31 @@ checkEqLType gr g t u trm = do (b,t',u',s) <- checkIfEqLType gr g t u trm case b of True -> return t' - False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$ - text "expected:" <+> ppType t $$ - text "inferred:" <+> ppType u + False -> + let inferredType = ppTerm Qualified 0 u + expectedType = ppTerm Qualified 0 t + term = ppTerm Unqualified 0 trm + funName = pp . head . words .render $ term + helpfulMsg = + case (arrows inferredType, arrows expectedType) of + (0,0) -> pp "" -- None of the types is a function + _ -> "\n **" <+> + if expectedType `isLessApplied` inferredType + then "Maybe you gave too few arguments to" <+> funName + else pp "Double-check that type signature and number of arguments match." + in checkError $ s <+> "type of" <+> term $$ + "expected:" <+> expectedType $$ -- ppqType t u $$ + "inferred:" <+> inferredType $$ -- ppqType u t + helpfulMsg + where + -- count the number of arrows in the prettyprinted term + arrows :: Doc -> Int + arrows = length . filter (=="->") . words . render + + -- If prettyprinted type t has fewer arrows then prettyprinted type u, + -- then t is "less applied", and we can print out more helpful error msg. + isLessApplied :: Doc -> Doc -> Bool + isLessApplied t u = arrows t < arrows u checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String) checkIfEqLType gr g t u trm = do @@ -617,60 +690,62 @@ checkIfEqLType gr g t u trm = do --- better: use a flag to forgive? (AR 31/1/2006) _ -> case missingLock [] t' u' of Ok lo -> do - checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo) + checkWarn $ "missing lock field" <+> fsep lo return (True,t',u',[]) Bad s -> return (False,t',u',s) where - -- t is a subtype of u + -- check that u is a subtype of t --- quick hack version of TC.eqVal - alpha g t u = case (t,u) of + alpha g t u = case (t,u) of -- error (the empty type!) is subtype of any other type (_,u) | u == typeError -> True -- contravariance - (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d - + (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d + -- record subtyping - (RecType rs, RecType ts) -> all (\ (l,a) -> - any (\ (k,b) -> alpha g a b && l == k) ts) rs + (RecType rs, RecType ts) -> all (\ (l,a) -> + any (\ (k,b) -> l == k && alpha g a b) ts) rs (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' (ExtR r s, t) -> alpha g r t || alpha g s t -- the following say that Ints n is a subset of Int and of Ints m >= n - (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n + -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04 + (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n | Just _ <- isTypeInts t, u == typeInt -> True ---- check size! | t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005 ---- this should be made in Rename - (Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n) + (Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n) || elem n (allExtendsPlus gr m) || m == n --- for Predef - (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) + (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) || elem n (allExtendsPlus gr m) - (QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n) + (QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n) || elem n (allExtendsPlus gr m) - (Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) + (Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) || elem n (allExtendsPlus gr m) - (Table a b, Table c d) -> alpha g a c && alpha g b d + -- contravariance + (Table a b, Table c d) -> alpha g c a && alpha g b d (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g - _ -> t == u + _ -> t == u --- the following should be one-way coercions only. AR 4/1/2001 || elem t sTypes && elem u sTypes - || (t == typeType && u == typePType) - || (u == typeType && t == typePType) + || (t == typeType && u == typePType) + || (u == typeType && t == typePType) - missingLock g t u = case (t,u) of - (RecType rs, RecType ts) -> - let - ls = [l | (l,a) <- rs, + missingLock g t u = case (t,u) of + (RecType rs, RecType ts) -> + let + ls = [l | (l,a) <- rs, not (any (\ (k,b) -> alpha g a b && l == k) ts)] (locks,others) = partition isLockLabel ls in case others of - _:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others))) + _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others))) _ -> return locks -- contravariance (Prod _ x a b, Prod _ y c d) -> do @@ -696,7 +771,7 @@ termWith t ct = do return (t,ty) -- | compositional check\/infer of binary operations -check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> +check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> Term -> Term -> Type -> Check (Term,Type) check2 chk con a b t = do a' <- chk a @@ -708,14 +783,18 @@ ppType :: Type -> Doc ppType ty = case ty of RecType fs -> case filter isLockLabel $ map fst fs of - [lock] -> text (drop 5 (showIdent (label2ident lock))) + [lock] -> pp (drop 5 (showIdent (label2ident lock))) _ -> ppTerm Unqualified 0 ty - Prod _ x a b -> ppType a <+> text "->" <+> ppType b + Prod _ x a b -> ppType a <+> "->" <+> ppType b _ -> ppTerm Unqualified 0 ty - +{- +ppqType :: Type -> Type -> Doc +ppqType t u = case (ppType t, ppType u) of + (pt,pu) | render pt == render pu -> ppTerm Qualified 0 t + (pt,_) -> pt +-} checkLookup :: Ident -> Context -> Check Type checkLookup x g = case [ty | (b,y,ty) <- g, x == y] of - [] -> checkError (text "unknown variable" <+> ppIdent x) + [] -> checkError ("unknown variable" <+> x) (ty:_) -> return ty --} diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index b35aaf9ed..ed3a20ce0 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -10,7 +10,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType) import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Grammar.Lockfield -import GF.Compile.Compute.ConcreteNew +import GF.Compile.Compute.Concrete import GF.Compile.Compute.Predef(predef,predefName) import GF.Infra.CheckM import GF.Data.Operations @@ -133,7 +133,7 @@ tcRho ge scope t@(RecType rs) (Just ty) = do [] -> unifyVar ge scope i env vs vtypePType _ -> return () ty -> do ty <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) ty - tcError ("The record type" <+> ppTerm Unqualified 0 t $$ + tcError ("The record type" <+> ppTerm Unqualified 0 t $$ "cannot be of type" <+> ppTerm Unqualified 0 ty) (rs,mb_ty) <- tcRecTypeFields ge scope rs (Just ty') return (f (RecType rs),ty) @@ -187,7 +187,7 @@ tcRho ge scope (R rs) (Just ty) = do case ty' of (VRecType ltys) -> do lttys <- checkRecFields ge scope rs ltys rs <- mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys - return ((f . R) rs, + return ((f . R) rs, VRecType [(l, ty) | (l,t,ty) <- lttys] ) ty -> do lttys <- inferRecFields ge scope rs @@ -277,11 +277,11 @@ tcApp ge scope (App fun arg) = -- APP2 varg <- liftErr (eval ge (scopeEnv scope) arg) return (App fun arg, res_ty varg) tcApp ge scope (Q id) = -- VAR (global) - mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> + mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> do ty <- liftErr (eval ge [] ty) return (t,ty) tcApp ge scope (QC id) = -- VAR (global) - mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> + mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> do ty <- liftErr (eval ge [] ty) return (t,ty) tcApp ge scope t = @@ -350,7 +350,7 @@ tcPatt ge scope (PM q) ty0 = do Bad err -> tcError (pp err) tcPatt ge scope p ty = unimplemented ("tcPatt "++show p) -inferRecFields ge scope rs = +inferRecFields ge scope rs = mapM (\(l,r) -> tcRecField ge scope l r Nothing) rs checkRecFields ge scope [] ltys @@ -368,7 +368,7 @@ checkRecFields ge scope ((l,t):lts) ltys = where takeIt l1 [] = (Nothing, []) takeIt l1 (lty@(l2,ty):ltys) - | l1 == l2 = (Just ty,ltys) + | l1 == l2 = (Just ty,ltys) | otherwise = let (mb_ty,ltys') = takeIt l1 ltys in (mb_ty,lty:ltys') @@ -390,13 +390,13 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do | s == cPType -> return mb_ty VMeta _ _ _ -> return mb_ty _ -> do sort <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) sort - tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$ + tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$ "cannot be of type" <+> ppTerm Unqualified 0 sort) (rs,mb_ty) <- tcRecTypeFields ge scope rs mb_ty return ((l,ty):rs,mb_ty) -- | Invariant: if the third argument is (Just rho), --- then rho is in weak-prenex form +-- then rho is in weak-prenex form instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho) instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1 instSigma ge scope t ty1 (Just ty2) = do -- INST2 @@ -444,11 +444,11 @@ subsCheckRho ge scope t (VApp p1 _) (VApp p2 _) -- Rule | predefName p1 == cInts && predefName p2 == cInt = return t subsCheckRho ge scope t (VApp p1 [VInt i]) (VApp p2 [VInt j]) -- Rule INT2 | predefName p1 == cInts && predefName p2 == cInts = - if i <= j + if i <= j then return t else tcError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j) subsCheckRho ge scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do -- Rule REC - let mkAccess scope t = + let mkAccess scope t = case t of ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1 (scope,mkProj2,mkWrap2) <- mkAccess scope t2 @@ -557,7 +557,7 @@ unify ge scope v (VMeta i env vs) = unifyVar ge scope i env vs v unify ge scope v1 v2 = do t1 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v1 t2 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v2 - tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$ + tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$ ppTerm Unqualified 0 t2)) -- | Invariant: tv1 is a flexible type variable @@ -568,9 +568,9 @@ unifyVar ge scope i env vs ty2 = do -- Check whether i is bound Bound ty1 -> do v <- liftErr (eval ge env ty1) unify ge scope (vapply (geLoc ge) v vs) ty2 Unbound scope' _ -> case value2term (geLoc ge) (scopeVars scope') ty2 of - Left i -> let (v,_) = reverse scope !! i - in tcError ("Variable" <+> pp v <+> "has escaped") - Right ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)] + -- Left i -> let (v,_) = reverse scope !! i + -- in tcError ("Variable" <+> pp v <+> "has escaped") + ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)] if i `elem` ms2 then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$ nest 2 (ppTerm Unqualified 0 ty2')) @@ -609,7 +609,7 @@ quantify ge scope t tvs ty0 = do ty <- tc_value2term (geLoc ge) (scopeVars scope) ty0 let used_bndrs = nub (bndrs ty) -- Avoid quantified type variables in use new_bndrs = take (length tvs) (allBinders \\ used_bndrs) - mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way + mapM_ bind (tvs `zip` new_bndrs) -- 'bind' is just a cunning way ty <- zonkTerm ty -- of doing the substitution vty <- liftErr (eval ge [] (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs)) return (foldr (Abs Implicit) t new_bndrs,vty) @@ -619,7 +619,7 @@ quantify ge scope t tvs ty0 = do bndrs (Prod _ x t1 t2) = [x] ++ bndrs t1 ++ bndrs t2 bndrs _ = [] -allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,... +allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,... allBinders = [ identS [x] | x <- ['a'..'z'] ] ++ [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']] @@ -631,8 +631,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++ type Scope = [(Ident,Value)] type Sigma = Value -type Rho = Value -- No top-level ForAll -type Tau = Value -- No ForAlls anywhere +type Rho = Value -- No top-level ForAll +type Tau = Value -- No ForAlls anywhere data MetaValue = Unbound Scope Sigma @@ -688,12 +688,12 @@ runTcM f = case unTcM f IntMap.empty [] of TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg newMeta :: Scope -> Sigma -> TcM MetaId -newMeta scope ty = TcM (\ms msgs -> +newMeta scope ty = TcM (\ms msgs -> let i = IntMap.size ms in TcOk i (IntMap.insert i (Unbound scope ty) ms) msgs) getMeta :: MetaId -> TcM MetaValue -getMeta i = TcM (\ms msgs -> +getMeta i = TcM (\ms msgs -> case IntMap.lookup i ms of Just mv -> TcOk mv ms msgs Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs)) @@ -702,7 +702,7 @@ setMeta :: MetaId -> MetaValue -> TcM () setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs) newVar :: Scope -> Ident -newVar scope = head [x | i <- [1..], +newVar scope = head [x | i <- [1..], let x = identS ('v':show i), isFree scope x] where @@ -721,11 +721,11 @@ getMetaVars loc sc_tys = do return (foldr go [] tys) where -- Get the MetaIds from a term; no duplicates in result - go (Vr tv) acc = acc + go (Vr tv) acc = acc go (App x y) acc = go x (go y acc) go (Meta i) acc - | i `elem` acc = acc - | otherwise = i : acc + | i `elem` acc = acc + | otherwise = i : acc go (Q _) acc = acc go (QC _) acc = acc go (Sort _) acc = acc @@ -741,10 +741,10 @@ getFreeVars loc sc_tys = do tys <- mapM (\(scope,ty) -> zonkTerm =<< tc_value2term loc (scopeVars scope) ty) sc_tys return (foldr (go []) [] tys) where - go bound (Vr tv) acc - | tv `elem` bound = acc - | tv `elem` acc = acc - | otherwise = tv : acc + go bound (Vr tv) acc + | tv `elem` bound = acc + | tv `elem` acc = acc + | otherwise = tv : acc go bound (App x y) acc = go bound x (go bound y acc) go bound (Meta _) acc = acc go bound (Q _) acc = acc @@ -765,13 +765,13 @@ zonkTerm (Meta i) = do zonkTerm t = composOp zonkTerm t tc_value2term loc xs v = - case value2term loc xs v of - Left i -> tcError ("Variable #" <+> pp i <+> "has escaped") - Right t -> return t + return $ value2term loc xs v + -- Old value2term error message: + -- Left i -> tcError ("Variable #" <+> pp i <+> "has escaped") -data TcA x a +data TcA x a = TcSingle (MetaStore -> [Message] -> TcResult a) | TcMany [x] (MetaStore -> [Message] -> [(a,MetaStore,[Message])]) diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs deleted file mode 100644 index aa13d5406..000000000 --- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs +++ /dev/null @@ -1,801 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -module GF.Compile.TypeCheck.RConcrete( checkLType, inferLType, computeLType, ppType ) where -import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint - -import GF.Infra.CheckM -import GF.Data.Operations - -import GF.Grammar -import GF.Grammar.Lookup -import GF.Grammar.Predef -import GF.Grammar.PatternMatch -import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord) -import GF.Compile.TypeCheck.Primitives - -import Data.List -import Control.Monad -import GF.Text.Pretty - -computeLType :: SourceGrammar -> Context -> Type -> Check Type -computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t - where - comp g ty = case ty of - _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed - | isPredefConstant ty -> return ty ---- shouldn't be needed - - Q (m,ident) -> checkIn ("module" <+> m) $ do - ty' <- lookupResDef gr (m,ident) - if ty' == ty then return ty else comp g ty' --- is this necessary to test? - - AdHocOverload ts -> do - over <- getOverload gr g (Just typeType) t - case over of - Just (tr,_) -> return tr - _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t) - - Vr ident -> checkLookup ident g -- never needed to compute! - - App f a -> do - f' <- comp g f - a' <- comp g a - case f' of - Abs b x t -> comp ((b,x,a'):g) t - _ -> return $ App f' a' - - Prod bt x a b -> do - a' <- comp g a - b' <- comp ((bt,x,Vr x) : g) b - return $ Prod bt x a' b' - - Abs bt x b -> do - b' <- comp ((bt,x,Vr x):g) b - return $ Abs bt x b' - - Let (x,(_,a)) b -> comp ((Explicit,x,a):g) b - - ExtR r s -> do - r' <- comp g r - s' <- comp g s - case (r',s') of - (RecType rs, RecType ss) -> plusRecType r' s' >>= comp g - _ -> return $ ExtR r' s' - - RecType fs -> do - let fs' = sortRec fs - liftM RecType $ mapPairsM (comp g) fs' - - ELincat c t -> do - t' <- comp g t - lockRecType c t' ---- locking to be removed AR 20/6/2009 - - _ | ty == typeTok -> return typeStr - _ | isPredefConstant ty -> return ty - - _ -> composOp (comp g) ty - --- the underlying algorithms - -inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type) -inferLType gr g trm = case trm of - - Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of - Just ty -> return ty - Nothing -> checkError ("unknown in Predef:" <+> ident) - - Q ident -> checks [ - termWith trm $ lookupResType gr ident >>= computeLType gr g - , - lookupResDef gr ident >>= inferLType gr g - , - checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm) - ] - - QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of - Just ty -> return ty - Nothing -> checkError ("unknown in Predef:" <+> ident) - - QC ident -> checks [ - termWith trm $ lookupResType gr ident >>= computeLType gr g - , - lookupResDef gr ident >>= inferLType gr g - , - checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm) - ] - - Vr ident -> termWith trm $ checkLookup ident g - - Typed e t -> do - t' <- computeLType gr g t - checkLType gr g e t' - - AdHocOverload ts -> do - over <- getOverload gr g Nothing trm - case over of - Just trty -> return trty - _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) - - App f a -> do - over <- getOverload gr g Nothing trm - case over of - Just trty -> return trty - _ -> do - (f',fty) <- inferLType gr g f - fty' <- computeLType gr g fty - case fty' of - Prod bt z arg val -> do - a' <- justCheck g a arg - ty <- if isWildIdent z - then return val - else substituteLType [(bt,z,a')] val - return (App f' a',ty) - _ -> - let term = ppTerm Unqualified 0 f - funName = pp . head . words .render $ term - in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$ - "\n ** Maybe you gave too many arguments to" <+> funName <+> "\n") - - S f x -> do - (f', fty) <- inferLType gr g f - case fty of - Table arg val -> do - x'<- justCheck g x arg - return (S f' x', val) - _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm)) - - P t i -> do - (t',ty) <- inferLType gr g t --- ?? - ty' <- computeLType gr g ty - let tr2 = P t' i - termWith tr2 $ case ty' of - RecType ts -> case lookup i ts of - Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty')) - Just x -> return x - _ -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$ - " instead of the inferred:" <+> ppTerm Unqualified 0 ty') - - R r -> do - let (ls,fs) = unzip r - fsts <- mapM inferM fs - let ts = [ty | (Just ty,_) <- fsts] - checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts) - return $ (R (zip ls fsts), RecType (zip ls ts)) - - T (TTyped arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - checkLType gr g trm (Table arg val) - T (TComp arg) pts -> do - (_,val) <- checks $ map (inferCase (Just arg)) pts - checkLType gr g trm (Table arg val) - T ti pts -> do -- tries to guess: good in oper type inference - let pts' = [pt | pt@(p,_) <- pts, isConstPatt p] - case pts' of - [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm) ----- PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] - _ -> do - (arg,val) <- checks $ map (inferCase Nothing) pts' - checkLType gr g trm (Table arg val) - V arg pts -> do - (_,val) <- checks $ map (inferLType gr g) pts --- return (trm, Table arg val) -- old, caused issue 68 - checkLType gr g trm (Table arg val) - - K s -> do - if elem ' ' s - then do - let ss = foldr C Empty (map K (words s)) - ----- removed irritating warning AR 24/5/2008 - ----- checkWarn ("token \"" ++ s ++ - ----- "\" converted to token list" ++ prt ss) - return (ss, typeStr) - else return (trm, typeStr) - - EInt i -> return (trm, typeInt) - - EFloat i -> return (trm, typeFloat) - - Empty -> return (trm, typeStr) - - C s1 s2 -> - check2 (flip (justCheck g) typeStr) C s1 s2 typeStr - - Glue s1 s2 -> - check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok - ----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007 - Strs (Cn c : ts) | c == cConflict -> do - checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts)) - inferLType gr g (head ts) - - Strs ts -> do - ts' <- mapM (\t -> justCheck g t typeStr) ts - return (Strs ts', typeStrs) - - Alts t aa -> do - t' <- justCheck g t typeStr - aa' <- flip mapM aa (\ (c,v) -> do - c' <- justCheck g c typeStr - v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr] - return (c',v')) - return (Alts t' aa', typeStr) - - RecType r -> do - let (ls,ts) = unzip r - ts' <- mapM (flip (justCheck g) typeType) ts - return (RecType (zip ls ts'), typeType) - - ExtR r s -> do - ---- over <- getOverload gr g Nothing r ---- let r1 = maybe r fst over - let r1 = r --- - - (r',rT) <- inferLType gr g r1 - rT' <- computeLType gr g rT - - (s',sT) <- inferLType gr g s - sT' <- computeLType gr g sT - - let trm' = ExtR r' s' - case (rT', sT') of - (RecType rs, RecType ss) -> do - let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields - checkLType gr g trm' rt ---- return (trm', rt) - _ | rT' == typeType && sT' == typeType -> do - return (trm', typeType) - _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm) - - Sort _ -> - termWith trm $ return typeType - - Prod bt x a b -> do - a' <- justCheck g a typeType - b' <- justCheck ((bt,x,a'):g) b typeType - return (Prod bt x a' b', typeType) - - Table p t -> do - p' <- justCheck g p typeType --- check p partype! - t' <- justCheck g t typeType - return $ (Table p' t', typeType) - - FV vs -> do - (_,ty) <- checks $ map (inferLType gr g) vs ---- checkIfComplexVariantType trm ty - checkLType gr g trm ty - - EPattType ty -> do - ty' <- justCheck g ty typeType - return (EPattType ty',typeType) - EPatt p -> do - ty <- inferPatt p - return (trm, EPattType ty) - - ELin c trm -> do - (trm',ty) <- inferLType gr g trm - ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009 - return $ (ELin c trm', ty') - - _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm) - - where - isPredef m = elem m [cPredef,cPredefAbs] - - justCheck g ty te = checkLType gr g ty te >>= return . fst - - -- for record fields, which may be typed - inferM (mty, t) = do - (t', ty') <- case mty of - Just ty -> checkLType gr g t ty - _ -> inferLType gr g t - return (Just ty',t') - - inferCase mty (patt,term) = do - arg <- maybe (inferPatt patt) return mty - cont <- pattContext gr g arg patt - (_,val) <- inferLType gr (reverse cont ++ g) term - return (arg,val) - isConstPatt p = case p of - PC _ ps -> True --- all isConstPatt ps - PP _ ps -> True --- all isConstPatt ps - PR ps -> all (isConstPatt . snd) ps - PT _ p -> isConstPatt p - PString _ -> True - PInt _ -> True - PFloat _ -> True - PChar -> True - PChars _ -> True - PSeq p q -> isConstPatt p && isConstPatt q - PAlt p q -> isConstPatt p && isConstPatt q - PRep p -> isConstPatt p - PNeg p -> isConstPatt p - PAs _ p -> isConstPatt p - _ -> False - - inferPatt p = case p of - PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c)) - PAs _ p -> inferPatt p - PNeg p -> inferPatt p - PAlt p q -> checks [inferPatt p, inferPatt q] - PSeq _ _ -> return $ typeStr - PRep _ -> return $ typeStr - PChar -> return $ typeStr - PChars _ -> return $ typeStr - _ -> inferLType gr g (patt2term p) >>= return . snd - --- type inference: Nothing, type checking: Just t --- the latter permits matching with value type -getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type)) -getOverload gr g mt ot = case appForm ot of - (f@(Q c), ts) -> case lookupOverload gr c of - Ok typs -> do - ttys <- mapM (inferLType gr g) ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - (AdHocOverload cs@(f:_), ts) -> do --- the function name f is only used in error messages - let typs = concatMap collectOverloads cs - ttys <- mapM (inferLType gr g) ts - v <- matchOverload f typs ttys - return $ Just v - _ -> return Nothing - - where - collectOverloads tr@(Q c) = case lookupOverload gr c of - Ok typs -> typs - _ -> case lookupResType gr c of - Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))] - _ -> [] - collectOverloads _ = [] --- constructors QC - - matchOverload f typs ttys = do - let (tts,tys) = unzip ttys - let vfs = lookupOverloadInstance tys typs - let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v] - let showTypes ty = hsep (map ppType ty) - - - let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs]) - - -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013 - let (stysError,stypsError) = if elem (render stys) (map render styps) - then (hsep (map (ppTerm Unqualified 0) tys), [hsep (map (ppTerm Unqualified 0) ty) | (ty,_) <- typs]) - else (stys,styps) - - case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of - ([(_,val,fun)],_) -> return (mkApp fun tts, val) - ([],[(pre,val,fun)]) -> do - checkWarn $ "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$ - "for" $$ - nest 2 (showTypes tys) $$ - "using" $$ - nest 2 (showTypes pre) - return (mkApp fun tts, val) - ([],[]) -> do - checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$ - maybe empty (\x -> "with value type" <+> ppType x) mt $$ - "for argument list" $$ - nest 2 stysError $$ - "among alternatives" $$ - nest 2 (vcat stypsError) - - - (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of - ([(val,fun)],_) -> do - return (mkApp fun tts, val) - ([],[(val,fun)]) -> do - checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) - return (mkApp fun tts, val) - ------ unsafely exclude irritating warning AR 24/5/2008 ------ checkWarn $ "overloading of" +++ prt f +++ ------ "resolved by excluding partial applications:" ++++ ------ unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)] - ---- now forgiving ambiguity with a warning AR 1/2/2014 --- This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before. --- But it also gives a chance to ambiguous overloadings that were banned before. - (nps1,nps2) -> do - checkWarn $ "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+> - ---- "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$ - "resolved by selecting the first of the alternatives" $$ - nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []]) - case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of - [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f - h:_ -> return h - - matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)] - - unlocked v = case v of - RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs) - _ -> v - ---- TODO: accept subtypes - ---- TODO: use a trie - lookupOverloadInstance tys typs = - [((pre,mkFunType rest val, t),isExact) | - let lt = length tys, - (ty,(val,t)) <- typs, length ty >= lt, - let (pre,rest) = splitAt lt ty, - let isExact = pre == tys, - isExact || map unlocked pre == map unlocked tys - ] - - noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v] - - noProd ty = case ty of - Prod _ _ _ _ -> False - _ -> True - -checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type) -checkLType gr g trm typ0 = do - typ <- computeLType gr g typ0 - - case trm of - - Abs bt x c -> do - case typ of - Prod bt' z a b -> do - (c',b') <- if isWildIdent z - then checkLType gr ((bt,x,a):g) c b - else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b - checkLType gr ((bt,x,a):g) c b' - return $ (Abs bt x c', Prod bt' z a b') - _ -> checkError $ "function type expected instead of" <+> ppType typ $$ - "\n ** Double-check that the type signature of the operation" $$ - "matches the number of arguments given to it.\n" - - App f a -> do - over <- getOverload gr g (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- inferLType gr g trm - termWith trm' $ checkEqLType gr g typ ty' trm' - - AdHocOverload ts -> do - over <- getOverload gr g Nothing trm - case over of - Just trty -> return trty - _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) - - Q _ -> do - over <- getOverload gr g (Just typ) trm - case over of - Just trty -> return trty - _ -> do - (trm',ty') <- inferLType gr g trm - termWith trm' $ checkEqLType gr g typ ty' trm' - - T _ [] -> - checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ) - T _ cs -> case typ of - Table arg val -> do - case allParamValues gr arg of - Ok vs -> do - let ps0 = map fst cs - ps <- testOvershadow ps0 vs - if null ps - then return () - else checkWarn ("patterns never reached:" $$ - nest 2 (vcat (map (ppPatt Unqualified 0) ps))) - _ -> return () -- happens with variable types - cs' <- mapM (checkCase arg val) cs - return (T (TTyped arg) cs', typ) - _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ) - V arg0 vs -> - case typ of - Table arg1 val -> - do arg' <- checkEqLType gr g arg0 arg1 trm - vs1 <- allParamValues gr arg1 - if length vs1 == length vs - then return () - else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm - vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs] - return (V arg' vs',typ) - - R r -> case typ of --- why needed? because inference may be too difficult - RecType rr -> do - --let (ls,_) = unzip rr -- labels of expected type - fsts <- mapM (checkM r) rr -- check that they are found in the record - return $ (R fsts, typ) -- normalize record - - _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ)) - - ExtR r s -> case typ of - _ | typ == typeType -> do - trm' <- computeLType gr g trm - case trm' of - RecType _ -> termWith trm' $ return typeType - ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType - -- ext t = t ** ... - _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm)) - - RecType rr -> do - - ll2 <- case s of - R ss -> return $ map fst ss - _ -> do - (s',typ2) <- inferLType gr g s - case typ2 of - RecType ss -> return $ map fst ss - _ -> checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2)) - let ll1 = [l | (l,_) <- rr, notElem l ll2] - ---- over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020 ---- let r1 = maybe r fst over - let r1 = r --- - - (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1]) - (s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2]) - - let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2]) - return (rec, typ) - - ExtR ty ex -> do - r' <- justCheck g r ty - s' <- justCheck g s ex - return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ - - _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ) - - FV vs -> do - ttys <- mapM (flip (checkLType gr g) typ) vs ---- checkIfComplexVariantType trm typ - return (FV (map fst ttys), typ) --- typ' ? - - S tab arg -> checks [ do - (tab',ty) <- inferLType gr g tab - ty' <- computeLType gr g ty - case ty' of - Table p t -> do - (arg',val) <- checkLType gr g arg p - checkEqLType gr g typ t trm - return (S tab' arg', t) - _ -> checkError ("table type expected for applied table instead of" <+> ppType ty') - , do - (arg',ty) <- inferLType gr g arg - ty' <- computeLType gr g ty - (tab',_) <- checkLType gr g tab (Table ty' typ) - return (S tab' arg', typ) - ] - Let (x,(mty,def)) body -> case mty of - Just ty -> do - (ty0,_) <- checkLType gr g ty typeType - (def',ty') <- checkLType gr g def ty0 - body' <- justCheck ((Explicit,x,ty'):g) body typ - return (Let (x,(Just ty',def')) body', typ) - _ -> do - (def',ty) <- inferLType gr g def -- tries to infer type of local constant - checkLType gr g (Let (x,(Just ty,def')) body) typ - - ELin c tr -> do - tr1 <- unlockRecord c tr - checkLType gr g tr1 typ - - _ -> do - (trm',ty') <- inferLType gr g trm - termWith trm' $ checkEqLType gr g typ ty' trm' - where - justCheck g ty te = checkLType gr g ty te >>= return . fst -{- - recParts rr t = (RecType rr1,RecType rr2) where - (rr1,rr2) = partition (flip elem (map fst t) . fst) rr --} - checkM rms (l,ty) = case lookup l rms of - Just (Just ty0,t) -> do - checkEqLType gr g ty ty0 t - (t',ty') <- checkLType gr g t ty - return (l,(Just ty',t')) - Just (_,t) -> do - (t',ty') <- checkLType gr g t ty - return (l,(Just ty',t')) - _ -> checkError $ - if isLockLabel l - then let cat = drop 5 (showIdent (label2ident l)) - in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <> - "; try wrapping it with lin" <+> cat - else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms) - - checkCase arg val (p,t) = do - cont <- pattContext gr g arg p - t' <- justCheck (reverse cont ++ g) t val - return (p,t') - -pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context -pattContext env g typ p = case p of - PV x -> return [(Explicit,x,typ)] - PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006 - t <- lookupResType env (q,c) - let (cont,v) = typeFormCnc t - checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) - (length cont == length ps) - checkEqLType env g typ v (patt2term p) - mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat - PR r -> do - typ' <- computeLType env g typ - case typ' of - RecType t -> do - let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]] - ----- checkWarn $ prt p ++++ show pts ----- debug - mapM (uncurry (pattContext env g)) pts >>= return . concat - _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ') - PT t p' -> do - checkEqLType env g typ t (patt2term p') - pattContext env g typ p' - - PAs x p -> do - g' <- pattContext env g typ p - return ((Explicit,x,typ):g') - - PAlt p' q -> do - g1 <- pattContext env g typ p' - g2 <- pattContext env g typ q - let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1]) - checkCond - ("incompatible bindings of" <+> - fsep pts <+> - "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) - return g1 -- must be g1 == g2 - PSeq p q -> do - g1 <- pattContext env g typ p - g2 <- pattContext env g typ q - return $ g1 ++ g2 - PRep p' -> noBind typeStr p' - PNeg p' -> noBind typ p' - - _ -> return [] ---- check types! - where - noBind typ p' = do - co <- pattContext env g typ p' - if not (null co) - then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p) - >> return [] - else return [] - -checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type -checkEqLType gr g t u trm = do - (b,t',u',s) <- checkIfEqLType gr g t u trm - case b of - True -> return t' - False -> - let inferredType = ppTerm Qualified 0 u - expectedType = ppTerm Qualified 0 t - term = ppTerm Unqualified 0 trm - funName = pp . head . words .render $ term - helpfulMsg = - case (arrows inferredType, arrows expectedType) of - (0,0) -> pp "" -- None of the types is a function - _ -> "\n **" <+> - if expectedType `isLessApplied` inferredType - then "Maybe you gave too few arguments to" <+> funName - else pp "Double-check that type signature and number of arguments match." - in checkError $ s <+> "type of" <+> term $$ - "expected:" <+> expectedType $$ -- ppqType t u $$ - "inferred:" <+> inferredType $$ -- ppqType u t - helpfulMsg - where - -- count the number of arrows in the prettyprinted term - arrows :: Doc -> Int - arrows = length . filter (=="->") . words . render - - -- If prettyprinted type t has fewer arrows then prettyprinted type u, - -- then t is "less applied", and we can print out more helpful error msg. - isLessApplied :: Doc -> Doc -> Bool - isLessApplied t u = arrows t < arrows u - -checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String) -checkIfEqLType gr g t u trm = do - t' <- computeLType gr g t - u' <- computeLType gr g u - case t' == u' || alpha [] t' u' of - True -> return (True,t',u',[]) - -- forgive missing lock fields by only generating a warning. - --- better: use a flag to forgive? (AR 31/1/2006) - _ -> case missingLock [] t' u' of - Ok lo -> do - checkWarn $ "missing lock field" <+> fsep lo - return (True,t',u',[]) - Bad s -> return (False,t',u',s) - - where - - -- check that u is a subtype of t - --- quick hack version of TC.eqVal - alpha g t u = case (t,u) of - - -- error (the empty type!) is subtype of any other type - (_,u) | u == typeError -> True - - -- contravariance - (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d - - -- record subtyping - (RecType rs, RecType ts) -> all (\ (l,a) -> - any (\ (k,b) -> l == k && alpha g a b) ts) rs - (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s' - (ExtR r s, t) -> alpha g r t || alpha g s t - - -- the following say that Ints n is a subset of Int and of Ints m >= n - -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04 - (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n - | Just _ <- isTypeInts t, u == typeInt -> True ---- check size! - | t == typeInt, Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005 - - ---- this should be made in Rename - (Q (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr m) - || m == n --- for Predef - (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr m) - (QC (m,a), Q (n,b)) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr m) - (Q (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) - || elem n (allExtendsPlus gr m) - - -- contravariance - (Table a b, Table c d) -> alpha g c a && alpha g b d - (Vr x, Vr y) -> x == y || elem (x,y) g || elem (y,x) g - _ -> t == u - --- the following should be one-way coercions only. AR 4/1/2001 - || elem t sTypes && elem u sTypes - || (t == typeType && u == typePType) - || (u == typeType && t == typePType) - - missingLock g t u = case (t,u) of - (RecType rs, RecType ts) -> - let - ls = [l | (l,a) <- rs, - not (any (\ (k,b) -> alpha g a b && l == k) ts)] - (locks,others) = partition isLockLabel ls - in case others of - _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others))) - _ -> return locks - -- contravariance - (Prod _ x a b, Prod _ y c d) -> do - ls1 <- missingLock g c a - ls2 <- missingLock g b d - return $ ls1 ++ ls2 - - _ -> Bad "" - - sTypes = [typeStr, typeTok, typeString] - --- auxiliaries - --- | light-weight substitution for dep. types -substituteLType :: Context -> Type -> Check Type -substituteLType g t = case t of - Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g] - _ -> composOp (substituteLType g) t - -termWith :: Term -> Check Type -> Check (Term, Type) -termWith t ct = do - ty <- ct - return (t,ty) - --- | compositional check\/infer of binary operations -check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> - Term -> Term -> Type -> Check (Term,Type) -check2 chk con a b t = do - a' <- chk a - b' <- chk b - return (con a' b', t) - --- printing a type with a lock field lock_C as C -ppType :: Type -> Doc -ppType ty = - case ty of - RecType fs -> case filter isLockLabel $ map fst fs of - [lock] -> pp (drop 5 (showIdent (label2ident lock))) - _ -> ppTerm Unqualified 0 ty - Prod _ x a b -> ppType a <+> "->" <+> ppType b - _ -> ppTerm Unqualified 0 ty -{- -ppqType :: Type -> Type -> Doc -ppqType t u = case (ppType t, ppType u) of - (pt,pu) | render pt == render pu -> ppTerm Qualified 0 t - (pt,_) -> pt --} -checkLookup :: Ident -> Context -> Check Type -checkLookup x g = - case [ty | (b,y,ty) <- g, x == y] of - [] -> checkError ("unknown variable" <+> x) - (ty:_) -> return ty diff --git a/src/compiler/GF/Compile/TypeCheck/TC.hs b/src/compiler/GF/Compile/TypeCheck/TC.hs index abcb24617..c0df83394 100644 --- a/src/compiler/GF/Compile/TypeCheck/TC.hs +++ b/src/compiler/GF/Compile/TypeCheck/TC.hs @@ -5,21 +5,22 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/02 20:50:19 $ +-- > CVS $Date: 2005/10/02 20:50:19 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.11 $ -- -- Thierry Coquand's type checking algorithm that creates a trace ----------------------------------------------------------------------------- -module GF.Compile.TypeCheck.TC (AExp(..), - Theory, - checkExp, - inferExp, - checkBranch, - eqVal, - whnf - ) where +module GF.Compile.TypeCheck.TC ( + AExp(..), + Theory, + checkExp, + inferExp, + checkBranch, + eqVal, + whnf + ) where import GF.Data.Operations import GF.Grammar @@ -31,17 +32,17 @@ import Data.Maybe import GF.Text.Pretty data AExp = - AVr Ident Val + AVr Ident Val | ACn QIdent Val - | AType - | AInt Int + | AType + | AInt Int | AFloat Double | AStr String | AMeta MetaId Val | ALet (Ident,(Val,AExp)) AExp - | AApp AExp AExp Val - | AAbs Ident Val AExp - | AProd Ident AExp AExp + | AApp AExp AExp Val + | AAbs Ident Val AExp + | AProd Ident AExp AExp -- -- | AEqs [([Exp],AExp)] --- not used | ARecType [ALabelling] | AR [AAssign] @@ -50,7 +51,7 @@ data AExp = | AData Val deriving (Eq,Show) -type ALabelling = (Label, AExp) +type ALabelling = (Label, AExp) type AAssign = (Label, (Val, AExp)) type Theory = QIdent -> Err Val @@ -71,7 +72,7 @@ whnf :: Val -> Err Val whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug case v of VApp u w -> do - u' <- whnf u + u' <- whnf u w' <- whnf w app u' w' VClos env e -> eval env e @@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val app u v = case u of VClos env (Abs _ x e) -> eval ((x,v):env) e _ -> return $ VApp u v - + eval :: Env -> Term -> Err Val -eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ +eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ case e of Vr x -> lookupVar env x Q c -> return $ VCn c @@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ _ -> return $ VClos env e eqVal :: Int -> Val -> Val -> Err [(Val,Val)] -eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ +eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ do w1 <- whnf u1 - w2 <- whnf u2 + w2 <- whnf u2 let v = VGen k case (w1,w2) of (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) -> eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) -> - liftM2 (++) + liftM2 (++) (eqVal k (VClos env1 a1) (VClos env2 a2)) (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] - (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] + (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] --- thus ignore qualifications; valid because inheritance cannot - --- be qualified. Simplifies annotation. AR 17/3/2005 + --- be qualified. Simplifies annotation. AR 17/3/2005 _ -> return [(w1,w2) | w1 /= w2] -- invariant: constraints are in whnf @@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do Abs _ x t -> case typ of VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a --- - (t',cs) <- checkExp th - (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) - return (AAbs x a' t', cs) + a' <- whnf $ VClos env a --- + (t',cs) <- checkExp th + (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) + return (AAbs x a' t', cs) _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ)) Let (x, (mb_typ, e1)) e2 -> do @@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b return (AProd x a' b', csa ++ csb) - R xs -> + R xs -> case typ of VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of [] -> return () @@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do (e',w,cs1) <- inferExp th tenv e cs2 <- eqVal k w typ return (e',cs1 ++ cs2) - + inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)]) inferExp th tenv@(k,rho,gamma) e = case e of Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x @@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2 return (ALet (x,(val1,e1)) e2, val2, cs1++cs2) App f t -> do - (f',w,csf) <- inferExp th tenv f + (f',w,csf) <- inferExp th tenv f typ <- whnf w case typ of VClos env (Prod _ x a b) -> do (a',csa) <- checkExp th tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e)) @@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do return ((lbl,(val,aexp)),cs) checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)]) -checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ - chB tenv' ps' ty - where +checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ + chB tenv' ps' ty + where (ps',_,rho2,k') = ps2ts k ps tenv' = (k, rho2++rho, gamma) ---- k' ? @@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ typ <- whnf ty case typ of VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a + a' <- whnf $ VClos env a (p', sigma, binds, cs1) <- checkP tenv p y a' let tenv' = (length binds, sigma ++ rho, binds ++ gamma) ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) - return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt + return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ)) [] -> do (e,cs) <- checkExp th tenv t ty @@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] return (VClos sigma t, sigma, delta, cs) - ps2ts k = foldr p2t ([],0,[],k) + ps2ts k = foldr p2t ([],0,[],k) p2t p (ps,i,g,k) = case p of - PW -> (Meta i : ps, i+1,g,k) + PW -> (Meta i : ps, i+1,g,k) PV x -> (Vr x : ps, i, upd x k g,k+1) PAs x p -> p2t p (ps,i,g,k) PString s -> (K s : ps, i, g, k) PInt n -> (EInt n : ps, i, g, k) PFloat n -> (EFloat n : ps, i, g, k) - PP c xs -> (mkApp (Q c) xss : ps, j, g',k') + PP c xs -> (mkApp (Q c) xss : ps, j, g',k') where (xss,j,g',k') = foldr p2t ([],i,g,k) xs PImplArg p -> p2t p (ps,i,g,k) PTilde t -> (t : ps, i, g, k) @@ -307,8 +308,8 @@ checkPatt th tenv exp val = do case typ of VClos env (Prod _ x a b) -> do (a',_,csa) <- checkExpP tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) @@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) mkAnnot a ti = do (v,cs) <- ti return (a v, v, cs) - diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 4399405b8..7bbe1d8dc 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.8 $ -- @@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I buildAnyTree m = go Map.empty where go map [] = return map - go map ((c,j):is) = do + go map ((c,j):is) = case Map.lookup c map of Just i -> case unifyAnyInfo m i j of - Ok k -> go (Map.insert c k map) is - Bad _ -> fail $ render ("conflicting information in module"<+>m $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - "and" $+$ - nest 4 (ppJudgement Qualified (c,j))) + Ok k -> go (Map.insert c k map) is + Bad _ -> fail $ render ("conflicting information in module"<+>m $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + "and" $+$ + nest 4 (ppJudgement Qualified (c,j))) Nothing -> go (Map.insert c j map) is extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule @@ -51,14 +51,14 @@ extendModule cwd gr (name,m) ---- Should be replaced by real control. AR 4/2/2005 | mstatus m == MSIncomplete && isModCnc m = return (name,m) | otherwise = checkInModule cwd m NoLoc empty $ do - m' <- foldM extOne m (mextend m) + m' <- foldM extOne m (mextend m) return (name,m') where extOne mo (n,cond) = do m0 <- lookupModule gr n -- test that the module types match, and find out if the old is complete - unless (sameMType (mtype m) (mtype mo)) + unless (sameMType (mtype m) (mtype mo)) (checkError ("illegal extension type to module" <+> name)) let isCompl = isCompleteModule m0 @@ -67,7 +67,7 @@ extendModule cwd gr (name,m) js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo) -- if incomplete, throw away extension information - return $ + return $ if isCompl then mo {jments = js1} else mo {mextend= filter ((/=n) . fst) (mextend mo) @@ -75,7 +75,7 @@ extendModule cwd gr (name,m) ,jments = js1 } --- | rebuilding instance + interface, and "with" modules, prior to renaming. +-- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) = @@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js -- add the information given in interface into an instance module Nothing -> do - unless (null is || mstatus mi == MSIncomplete) - (checkError ("module" <+> i <+> + unless (null is || mstatus mi == MSIncomplete) + (checkError ("module" <+> i <+> "has open interfaces and must therefore be declared incomplete")) case mt of MTInstance (i0,mincl) -> do @@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js let stat' = if all (flip elem infs) is then MSComplete else MSIncomplete - unless (stat' == MSComplete || stat == MSIncomplete) + unless (stat' == MSComplete || stat == MSIncomplete) (checkError ("module" <+> i <+> "remains incomplete")) ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext let ops1 = nub $ @@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js extendMod :: Grammar -> Bool -> (Module,Ident -> Bool) -> ModuleName -> Map.Map Ident Info -> Check (Map.Map Ident Info) -extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) +extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) where try new (c,i0) | not (cond c) = return new | otherwise = case Map.lookup c new of Just j -> case unifyAnyInfo name i j of - Ok k -> return $ Map.insert c k new - Bad _ -> do (base,j) <- case j of - AnyInd _ m -> lookupOrigInfo gr (m,c) - _ -> return (base,j) - (name,i) <- case i of + Ok k -> return $ Map.insert c k new + Bad _ -> do (base,j) <- case j of + AnyInd _ m -> lookupOrigInfo gr (m,c) + _ -> return (base,j) + (name,i) <- case i of AnyInd _ m -> lookupOrigInfo gr (m,c) _ -> return (name,i) - checkError ("cannot unify the information" $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - "in module" <+> name <+> "with" $$ - nest 4 (ppJudgement Qualified (c,j)) $$ - "in module" <+> base) + checkError ("cannot unify the information" $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + "in module" <+> name <+> "with" $$ + nest 4 (ppJudgement Qualified (c,j)) $$ + "in module" <+> base) Nothing-> if isCompl then return $ Map.insert c (indirInfo name i) new else return $ Map.insert c i new @@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme i = globalizeLoc (msrc mi) i0 indirInfo :: ModuleName -> Info -> Info - indirInfo n info = AnyInd b n' where + indirInfo n info = AnyInd b n' where (b,n') = case info of ResValue _ -> (True,n) ResParam _ _ -> (True,n) - AbsFun _ _ Nothing _ -> (True,n) + AbsFun _ _ Nothing _ -> (True,n) AnyInd b k -> (b,k) _ -> (False,n) ---- canonical in Abs @@ -194,24 +194,24 @@ globalizeLoc fpath i = unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info unifyAnyInfo m i j = case (i,j) of - (AbsCat mc1, AbsCat mc2) -> + (AbsCat mc1, AbsCat mc2) -> liftM AbsCat (unifyMaybeL mc1 mc2) - (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> + (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs (ResParam mt1 mv1, ResParam mt2 mv2) -> liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2) - (ResValue (L l1 t1), ResValue (L l2 t2)) + (ResValue (L l1 t1), ResValue (L l2 t2)) | t1==t2 -> return (ResValue (L l1 t1)) | otherwise -> fail "" (_, ResOverload ms t) | elem m ms -> return $ ResOverload ms t - (ResOper mt1 m1, ResOper mt2 m2) -> + (ResOper mt1 m1, ResOper mt2 m2) -> liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2) - (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> + (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2) - (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> + (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2) (AnyInd b1 m1, AnyInd b2 m2) -> do diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs index 14cbf90d2..970de5c06 100644 --- a/src/compiler/GF/Data/BacktrackM.hs +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -16,18 +16,18 @@ {-# LANGUAGE CPP #-} module GF.Data.BacktrackM ( -- * the backtracking state monad - BacktrackM, - -- * monad specific utilities - member, - cut, - -- * running the monad - foldBM, runBM, - foldSolutions, solutions, - foldFinalStates, finalStates, - - -- * reexport the 'MonadState' class - module Control.Monad.State.Class, - ) where + BacktrackM, + -- * monad specific utilities + member, + cut, + -- * running the monad + foldBM, runBM, + foldSolutions, solutions, + foldFinalStates, finalStates, + + -- * reexport the 'MonadState' class + module Control.Monad.State.Class, + ) where import Data.List import Control.Applicative @@ -70,7 +70,7 @@ instance Applicative (BacktrackM s) where instance Monad (BacktrackM s) where return a = BM (\c s b -> c a s b) BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) - where unBM (BM m) = m + where unBM (BM m) = m #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail diff --git a/src/compiler/GF/Data/Graph.hs b/src/compiler/GF/Data/Graph.hs index 797325bbb..fd8ec9d99 100644 --- a/src/compiler/GF/Data/Graph.hs +++ b/src/compiler/GF/Data/Graph.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/10 16:43:44 $ +-- > CVS $Date: 2005/11/10 16:43:44 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.2 $ -- @@ -34,7 +34,7 @@ import Data.Set (Set) import qualified Data.Set as Set data Graph n a b = Graph [n] ![Node n a] ![Edge n b] - deriving (Eq,Show) + deriving (Eq,Show) type Node n a = (n,a) type Edge n b = (n,n,b) @@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es] -- | Add a node to the graph. newNode :: a -- ^ Node label - -> Graph n a b + -> Graph n a b -> (Graph n a b,n) -- ^ Node graph and name of new node newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c) @@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es -- lazy version: -- newEdges es' (Graph c ns es) = Graph c ns (es'++es) -insertEdgeWith :: Eq n => +insertEdgeWith :: Eq n => (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es) where h [] = [e] @@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n) -- | Remove a set of nodes and all edges to and from those nodes. removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b removeNodes xs (Graph c ns es) = Graph c ns' es' - where + where keepNode n = not (Set.member n xs) ns' = [ x | x@(n,_) <- ns, keepNode n ] es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ] @@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es' -- | Get a map of node names to info about each node. nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ] - where + where inc = groupEdgesBy edgeTo g out = groupEdgesBy edgeFrom g fn m n = fromMaybe [] (Map.lookup n m) @@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ] -- | Add the nodes from the second graph to the first graph. --- The nodes in the second graph will be renamed using the name +-- The nodes in the second graph will be renamed using the name -- supply in the first graph. -- This function is more efficient when the second graph -- is smaller than the first. -mergeGraphs :: Ord m => Graph n a b -> Graph m a b +mergeGraphs :: Ord m => Graph n a b -> Graph m a b -> (Graph n a b, m -> n) -- ^ The new graph and a function translating -- the old names of nodes in the second graph -- to names in the new graph. mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName) - where + where (xs,c') = splitAt (length (nodes g2)) c newNames = Map.fromList (zip (map fst (nodes g2)) xs) newName n = fromJust $ Map.lookup n newNames @@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function -> Graph n a b -> Graph m a b renameNodes newName c (Graph _ ns es) = Graph c ns' es' where ns' = map' (\ (n,x) -> (newName n,x)) ns - es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es + es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es -- | A strict 'map' map' :: (a -> b) -> [a] -> [b] diff --git a/src/compiler/GF/Data/Graphviz.hs b/src/compiler/GF/Data/Graphviz.hs index 411f76898..fa47bac67 100644 --- a/src/compiler/GF/Data/Graphviz.hs +++ b/src/compiler/GF/Data/Graphviz.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/15 18:10:44 $ +-- > CVS $Date: 2005/09/15 18:10:44 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.2 $ -- @@ -13,14 +13,14 @@ ----------------------------------------------------------------------------- module GF.Data.Graphviz ( - Graph(..), GraphType(..), - Node(..), Edge(..), - Attr, - addSubGraphs, - setName, - setAttr, - prGraphviz - ) where + Graph(..), GraphType(..), + Node(..), Edge(..), + Attr, + addSubGraphs, + setName, + setAttr, + prGraphviz + ) where import Data.Char @@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) = graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n" prSubGraph :: Graph -> String -prSubGraph g@(Graph _ i _ _ _ _) = +prSubGraph g@(Graph _ i _ _ _ _) = "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}" prGraph :: Graph -> String -prGraph (Graph t id at ns es ss) = +prGraph (Graph t id at ns es ss) = unlines $ map (++";") (map prAttr at - ++ map prNode ns - ++ map (prEdge t) es + ++ map prNode ns + ++ map (prEdge t) es ++ map prSubGraph ss) graphtype :: GraphType -> String @@ -96,7 +96,7 @@ edgeop Undirected = "--" prAttrList :: [Attr] -> String prAttrList [] = "" -prAttrList at = "[" ++ join "," (map prAttr at) ++ "]" +prAttrList at = "[" ++ join "," (map prAttr at) ++ "]" prAttr :: Attr -> String prAttr (n,v) = esc n ++ " = " ++ esc v diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 08fa15c3e..e9b95f8ab 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/11 16:12:41 $ +-- > CVS $Date: 2005/11/11 16:12:41 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.22 $ -- @@ -15,34 +15,34 @@ ----------------------------------------------------------------------------- module GF.Data.Operations ( - -- ** The Error monad - Err(..), err, maybeErr, testErr, fromErr, errIn, - lookupErr, + -- ** The Error monad + Err(..), err, maybeErr, testErr, fromErr, errIn, + lookupErr, - -- ** Error monad class - ErrorMonad(..), checks, --doUntil, allChecks, checkAgain, - liftErr, - - -- ** Checking - checkUnique, unifyMaybeBy, unifyMaybe, + -- ** Error monad class + ErrorMonad(..), checks, --doUntil, allChecks, checkAgain, + liftErr, - -- ** Monadic operations on lists and pairs - mapPairsM, pairM, - - -- ** Printing - indent, (+++), (++-), (++++), (+++-), (+++++), - prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, - prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, - numberedParagraphs, prConjList, prIfEmpty, wrapLines, + -- ** Checking + checkUnique, unifyMaybeBy, unifyMaybe, - -- ** Topological sorting - topoTest, topoTest2, + -- ** Monadic operations on lists and pairs + mapPairsM, pairM, - -- ** Misc - readIntArg, - iterFix, chunks, - - ) where + -- ** Printing + indent, (+++), (++-), (++++), (+++-), (+++++), + prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, + prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, + numberedParagraphs, prConjList, prIfEmpty, wrapLines, + + -- ** Topological sorting + topoTest, topoTest2, + + -- ** Misc + readIntArg, + iterFix, chunks, + + ) where import Data.Char (isSpace, toUpper, isSpace, isDigit) import Data.List (nub, partition, (\\)) @@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s (+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String a +++ b = a ++ " " ++ b -a ++- "" = a +a ++- "" = a a ++- b = a +++ b a ++++ b = a ++ "\n" ++ b @@ -145,20 +145,20 @@ prCurly s = "{" ++ s ++ "}" prBracket s = "[" ++ s ++ "]" prArgList, prSemicList, prCurlyList :: [String] -> String -prArgList = prParenth . prTList "," +prArgList = prParenth . prTList "," prSemicList = prTList " ; " prCurlyList = prCurly . prSemicList restoreEscapes :: String -> String -restoreEscapes s = - case s of +restoreEscapes s = + case s of [] -> [] '"' : t -> '\\' : '"' : restoreEscapes t '\\': t -> '\\' : '\\' : restoreEscapes t c : t -> c : restoreEscapes t numberedParagraphs :: [[String]] -> [String] -numberedParagraphs t = case t of +numberedParagraphs t = case t of [] -> [] p:[] -> p _ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t] @@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g) ([],[]) -> Just [] ([],_) -> Nothing (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest] - where leaves = map fst ns + where leaves = map fst ns -- | Fix point iterator (for computing e.g. transitive closures or reachability) iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] -iterFix more start = iter start start +iterFix more start = iter start start where iter old new = if (null new') then old @@ -241,7 +241,7 @@ liftErr e = err raise return e {- instance ErrorMonad (STM s) where raise msg = STM (\s -> raise msg) - handle (STM f) g = STM (\s -> (f s) + handle (STM f) g = STM (\s -> (f s) `handle` (\e -> let STM g' = (g e) in g' s)) diff --git a/src/compiler/GF/Data/Relation.hs b/src/compiler/GF/Data/Relation.hs index 5a3e80e6f..62da769b5 100644 --- a/src/compiler/GF/Data/Relation.hs +++ b/src/compiler/GF/Data/Relation.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/26 17:13:13 $ +-- > CVS $Date: 2005/10/26 17:13:13 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.1 $ -- @@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys) reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined. - -> Rel a -> Rel a + -> Rel a -> Rel a reflexiveClosure_ u r = relates [(x,x) | x <- u] r -- | Uses 'domain' @@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ] -- | Keep the related pairs for which the predicate is true. -filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a +filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p) -- | Remove keys that map to no elements. @@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a) purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r in (r', Map.keysSet r'') --- | Get the equivalence classes from an equivalence relation. +-- | Get the equivalence classes from an equivalence relation. equivalenceClasses :: Ord a => Rel a -> [Set a] equivalenceClasses r = equivalenceClasses_ (Map.keys r) r where equivalenceClasses_ [] _ = [] equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r - where ys = allRelated r x - zs = [x' | x' <- xs, not (x' `Set.member` ys)] + where ys = allRelated r x + zs = [x' | x' <- xs, not (x' `Set.member` ys)] isTransitive :: Ord a => Rel a -> Bool -isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, +isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, y <- Set.toList ys, z <- Set.toList (allRelated r y)] isReflexive :: Ord a => Rel a -> Bool @@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r Nothing -> (r', Set.empty, Set.empty) -- remove element from all incoming and outgoing sets -- of other elements - Just (is,os) -> + Just (is,os) -> let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os in (r''', is, os) @@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a incoming x r = maybe Set.empty fst $ Map.lookup x r --outgoing :: Ord a => a -> Rel' a -> Set a ---outgoing x r = maybe Set.empty snd $ Map.lookup x r \ No newline at end of file +--outgoing x r = maybe Set.empty snd $ Map.lookup x r diff --git a/src/compiler/GF/Data/Utilities.hs b/src/compiler/GF/Data/Utilities.hs index 29ed329dc..913953b6e 100644 --- a/src/compiler/GF/Data/Utilities.hs +++ b/src/compiler/GF/Data/Utilities.hs @@ -4,7 +4,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/26 18:47:16 $ +-- > CVS $Date: 2005/10/26 18:47:16 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.6 $ -- @@ -33,7 +33,7 @@ longerThan n = not . notLongerThan n lookupList :: Eq a => a -> [(a, b)] -> [b] lookupList a [] = [] lookupList a (p:ps) | a == fst p = snd p : lookupList a ps - | otherwise = lookupList a ps + | otherwise = lookupList a ps split :: [a] -> ([a], [a]) split (x : y : as) = (x:xs, y:ys) @@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys) foldMerge :: (a -> a -> a) -> a -> [a] -> a foldMerge merge zero = fm where fm [] = zero - fm [a] = a - fm abs = let (as, bs) = split abs in fm as `merge` fm bs + fm [a] = a + fm abs = let (as, bs) = split abs in fm as `merge` fm bs select :: [a] -> [(a, [a])] select [] = [] @@ -68,7 +68,7 @@ safeInit :: [a] -> [a] safeInit [] = [] safeInit xs = init xs --- | Sorts and then groups elements given an ordering of the +-- | Sorts and then groups elements given an ordering of the -- elements. sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]] sortGroupBy f = groupBy (compareEq f) . sortBy f diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 4adff02f2..e62424f6a 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -11,6 +11,7 @@ module GF.Grammar.Canonical where import Prelude hiding ((<>)) import GF.Text.Pretty +import GF.Infra.Ident (RawIdent) -- | A Complete grammar data Grammar = Grammar Abstract [Concrete] deriving Show @@ -44,12 +45,12 @@ data LincatDef = LincatDef CatId LinType deriving Show data LinDef = LinDef FunId [VarId] LinValue deriving Show -- | Linearization type, RHS of @lincat@ -data LinType = FloatType - | IntType +data LinType = FloatType + | IntType | ParamType ParamType | RecordType [RecordRowType] - | StrType - | TableType LinType LinType + | StrType + | TableType LinType LinType | TupleType [LinType] deriving (Eq,Ord,Show) @@ -59,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show) data LinValue = ConcatValue LinValue LinValue | LiteralValue LinLiteral | ErrorValue String - | ParamConstant ParamValue + | ParamConstant ParamValue | PredefValue PredefId | RecordValue [RecordRowValue] | TableValue LinType [TableRowValue] @@ -73,9 +74,9 @@ data LinValue = ConcatValue LinValue LinValue | CommentedValue String LinValue deriving (Eq,Ord,Show) -data LinLiteral = FloatConstant Float - | IntConstant Int - | StrConstant String +data LinLiteral = FloatConstant Float + | IntConstant Int + | StrConstant String deriving (Eq,Ord,Show) data LinPattern = ParamPattern ParamPattern @@ -106,7 +107,7 @@ newtype PredefId = PredefId Id deriving (Eq,Ord,Show) newtype LabelId = LabelId Id deriving (Eq,Ord,Show) data VarValueId = VarValueId QualId deriving (Eq,Ord,Show) --- | Name of param type or param value +-- | Name of param type or param value newtype ParamId = ParamId QualId deriving (Eq,Ord,Show) -------------------------------------------------------------------------------- @@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show -- *** Identifiers -type Id = String +type Id = RawIdent data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show) -------------------------------------------------------------------------------- @@ -249,7 +250,7 @@ instance PPA LinLiteral where FloatConstant f -> pp f IntConstant n -> pp n StrConstant s -> doubleQuotes s -- hmm - + instance RhsSeparator LinValue where rhsSep _ = pp "=" instance Pretty LinPattern where @@ -264,8 +265,7 @@ instance PPA LinPattern where ParamPattern pv -> ppA pv RecordPattern r -> block r TuplePattern ps -> "<"<>punctuate "," ps<>">" - WildPattern -> pp "_" - _ -> parens p + WildPattern -> pp "_" instance RhsSeparator LinPattern where rhsSep _ = pp "=" diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 0ec7f43e6..04c13df5e 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -7,6 +7,7 @@ import Control.Applicative ((<|>)) import Data.Ratio (denominator, numerator) import GF.Grammar.Canonical import Control.Monad (guard) +import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS) encodeJSON :: FilePath -> Grammar -> IO () @@ -29,7 +30,7 @@ instance JSON Grammar where -- ** Abstract Syntax instance JSON Abstract where - showJSON (Abstract absid flags cats funs) + showJSON (Abstract absid flags cats funs) = makeObj [("abs", showJSON absid), ("flags", showJSON flags), ("cats", showJSON cats), @@ -81,7 +82,7 @@ instance JSON TypeBinding where -- ** Concrete syntax instance JSON Concrete where - showJSON (Concrete cncid absid flags params lincats lins) + showJSON (Concrete cncid absid flags params lincats lins) = makeObj [("cnc", showJSON cncid), ("abs", showJSON absid), ("flags", showJSON flags), @@ -204,12 +205,12 @@ instance JSON a => JSON (RecordRow a) where -- record rows and lists of record rows are both encoded as JSON records (i.e., objects) showJSON row = showJSONs [row] showJSONs rows = makeObj (map toRow rows) - where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) + where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val) readJSON obj = head <$> readJSONs obj readJSONs obj = mapM fromRow (assocsJSObject obj) where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue - return (RecordRow (LabelId lbl) value) + return (RecordRow (LabelId (rawIdentS lbl)) value) instance JSON rhs => JSON (TableRow rhs) where showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] @@ -219,19 +220,19 @@ instance JSON rhs => JSON (TableRow rhs) where -- *** Identifiers in Concrete Syntax -instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON -instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON -instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON -instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON -instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON +instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON +instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON +instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON +instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON +instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON -------------------------------------------------------------------------------- -- ** Used in both Abstract and Concrete Syntax -instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON -instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON -instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON +instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON +instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON +instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON instance JSON VarId where -- the anonymous variable is the underscore: @@ -242,20 +243,24 @@ instance JSON VarId where <|> VarId <$> readJSON o instance JSON QualId where - showJSON (Qual (ModId m) n) = showJSON (m++"."++n) + showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n) showJSON (Unqual n) = showJSON n readJSON o = do qualid <- readJSON o let (mod, id) = span (/= '.') qualid - return $ if null mod then Unqual id else Qual (ModId mod) id + return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id) + +instance JSON RawIdent where + showJSON i = showJSON $ showRawIdent i + readJSON o = rawIdentS <$> readJSON o instance JSON Flags where -- flags are encoded directly as JSON records (i.e., objects): - showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs] + showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs] readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj) where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue - return (lbl, value) + return (rawIdentS lbl, value) instance JSON FlagValue where -- flag values are encoded as basic JSON types: diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index bde0aa064..365388726 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -267,7 +267,7 @@ type AlexInput2 = (AlexInput,AlexInput) data ParseResult a = POk AlexInput2 a - | PFailed Posn -- The position of the error + | PFailed Posn -- The position of the error String -- The error message newtype P a = P { unP :: AlexInput2 -> ParseResult a } diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 9f774fb2c..97aa5639e 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -6,7 +6,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/27 13:21:53 $ +-- > CVS $Date: 2005/10/27 13:21:53 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.15 $ -- @@ -20,17 +20,17 @@ module GF.Grammar.Lookup ( lookupOrigInfo, allOrigInfos, lookupResDef, lookupResDefLoc, - lookupResType, + lookupResType, lookupOverload, lookupOverloadTypes, - lookupParamValues, + lookupParamValues, allParamValues, - lookupAbsDef, - lookupLincat, + lookupAbsDef, + lookupLincat, lookupFunType, lookupCatContext, allOpers, allOpersTo - ) where + ) where import GF.Data.Operations import GF.Infra.Ident @@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x) lookupResDefLoc gr (m,c) | isPredefCat c = fmap noLoc (lock c defLinType) | otherwise = look m c - where + where look m c = do info <- lookupQIdentInfo gr (m,c) case info of @@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c) ResOper _ Nothing -> return (noLoc (Q (m,c))) CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty) CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType) - + CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr) CncFun _ (Just ltr) _ _ -> return ltr @@ -95,7 +95,7 @@ lookupResType gr (m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> return typeType CncFun (Just (cat,cont,val)) _ _ _ -> do - val' <- lock cat val + val' <- lock cat val return $ mkProd cont val' [] AnyInd _ n -> lookupResType gr (n,c) ResParam _ _ -> return typePType @@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> ret typeType CncFun (Just (cat,cont,val)) _ _ _ -> do - val' <- lock cat val + val' <- lock cat val ret $ mkProd cont val' [] ResParam _ _ -> ret typePType ResValue (L _ t) -> ret t @@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do case info of ResOverload os tysts -> do tss <- mapM (\x -> lookupOverload gr (x,c)) os - return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | - (L _ ty,L _ tr) <- tysts] ++ + return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | + (L _ ty,L _ tr) <- tysts] ++ concat tss AnyInd _ n -> lookupOverload gr (n,c) @@ -216,7 +216,7 @@ lookupCatContext gr m c = do -- notice that it only gives the modules that are reachable and the opers that are included allOpers :: Grammar -> [(QIdent,Type,Location)] -allOpers gr = +allOpers gr = [((m,op),typ,loc) | (m,mi) <- maybe [] (allExtends gr) (greatestResource gr), (op,info) <- Map.toList (jments mi), diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index b088fe49c..280aee141 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/11 16:38:00 $ +-- > CVS $Date: 2005/11/11 16:38:00 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.24 $ -- @@ -51,14 +51,14 @@ typeForm t = _ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t)) typeFormCnc :: Type -> (Context, Type) -typeFormCnc t = +typeFormCnc t = case t of Prod b x a t -> let (x', v) = typeFormCnc t in ((b,x,a):x',v) _ -> ([],t) valCat :: Type -> Cat -valCat typ = +valCat typ = let (_,cat,_) = typeForm typ in cat @@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do -- pessimistic choice contextOfType :: Monad m => Type -> m Context contextOfType typ = case typ of Prod b x a t -> liftM ((b,x,a):) $ contextOfType t - _ -> return [] + _ -> return [] termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term]) termForm t = case t of @@ -108,8 +108,8 @@ termForm t = case t of return ((b,x):x', fun, args) App c a -> do (_,fun, args) <- termForm c - return ([],fun,args ++ [a]) - _ -> + return ([],fun,args ++ [a]) + _ -> return ([],t,[]) termFormCnc :: Term -> ([(BindType,Ident)], Term) @@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term mkTable tt t = foldr Table t tt mkCTable :: [(BindType,Ident)] -> Term -> Term -mkCTable ids v = foldr ccase v ids where +mkCTable ids v = foldr ccase v ids where ccase (_,x) t = T TRaw [(PV x,t)] mkHypo :: Term -> Hypo @@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of filter (`elem` (map fst r1)) (map fst r2) of [] -> return (RecType (r1 ++ r2)) ls -> raise $ render ("clashing labels" <+> hsep ls) - _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) + _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) --plusRecord :: Term -> Term -> Err Term plusRecord t1 t2 = @@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel, typeStr)] -- | refreshing variables mkFreshVar :: [Ident] -> Ident -mkFreshVar olds = varX (maxVarIndex olds + 1) +mkFreshVar olds = varX (maxVarIndex olds + 1) -- | trying to preserve a given symbol mkFreshVarX :: [Ident] -> Ident -> Ident @@ -313,7 +313,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x maxVarIndex :: [Ident] -> Int maxVarIndex = maximum . ((-1):) . map varIndex -mkFreshVars :: Int -> [Ident] -> [Ident] +mkFreshVars :: Int -> [Ident] -> [Ident] mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]] -- | quick hack for refining with var in editor @@ -413,11 +413,11 @@ patt2term pt = case pt of PC c pp -> mkApp (Con c) (map patt2term pp) PP c pp -> mkApp (QC c) (map patt2term pp) - PR r -> R [assign l (patt2term p) | (l,p) <- r] + PR r -> R [assign l (patt2term p) | (l,p) <- r] PT _ p -> patt2term p PInt i -> EInt i PFloat i -> EFloat i - PString s -> K s + PString s -> K s PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding PChar -> appCons cChar [] --- an encoding @@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op) -- | to define compositional term functions composOp :: Monad m => (Term -> m Term) -> Term -> m Term -composOp co trm = +composOp co trm = case trm of App c a -> liftM2 App (co c) (co a) Abs b x t -> liftM (Abs b x) (co t) @@ -552,13 +552,13 @@ strsFromTerm t = case t of v0 <- mapM (strsFromTerm . fst) vs c0 <- mapM (strsFromTerm . snd) vs --let vs' = zip v0 c0 - return [strTok (str2strings def) vars | + return [strTok (str2strings def) vars | def <- d0, - vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | + vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | vv <- sequence v0] ] FV ts -> mapM strsFromTerm ts >>= return . concat - Strs ts -> mapM strsFromTerm ts >>= return . concat + Strs ts -> mapM strsFromTerm ts >>= return . concat _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t)) getTableType :: TInfo -> Err Type @@ -590,11 +590,11 @@ noExist = FV [] defaultLinType :: Type defaultLinType = mkRecType linLabel [typeStr] --- normalize records and record types; put s first +-- | normalize records and record types; put s first sortRec :: [(Label,a)] -> [(Label,a)] sortRec = sortBy ordLabel where - ordLabel (r1,_) (r2,_) = + ordLabel (r1,_) (r2,_) = case (showIdent (label2ident r1), showIdent (label2ident r2)) of ("s",_) -> LT (_,"s") -> GT @@ -605,7 +605,7 @@ sortRec = sortBy ordLabel where -- | dependency check, detecting circularities and returning topo-sorted list allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])] -allDependencies ism b = +allDependencies ism b = [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b] where opersIn t = case t of diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs index 9ef191554..dc0a5d3a5 100644 --- a/src/compiler/GF/Grammar/PatternMatch.hs +++ b/src/compiler/GF/Grammar/PatternMatch.hs @@ -5,18 +5,19 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/12 12:38:29 $ +-- > CVS $Date: 2005/10/12 12:38:29 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.7 $ -- -- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 ----------------------------------------------------------------------------- -module GF.Grammar.PatternMatch (matchPattern, - testOvershadow, - findMatch, - measurePatt - ) where +module GF.Grammar.PatternMatch ( + matchPattern, + testOvershadow, + findMatch, + measurePatt + ) where import GF.Data.Operations import GF.Grammar.Grammar @@ -30,7 +31,7 @@ import GF.Text.Pretty --import Debug.Trace matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution) -matchPattern pts term = +matchPattern pts term = if not (isInConstantForm term) then raise (render ("variables occur in" <+> pp term)) else do @@ -61,15 +62,15 @@ testOvershadow pts vs = do findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution) findMatch cases terms = case cases of [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms))) - (patts,_):_ | length patts /= length terms -> - raise (render ("wrong number of args for patterns :" <+> hsep patts <+> + (patts,_):_ | length patts /= length terms -> + raise (render ("wrong number of args for patterns :" <+> hsep patts <+> "cannot take" <+> hsep terms)) (patts,val):cc -> case mapM tryMatch (zip patts terms) of Ok substs -> return (val, concat substs) _ -> findMatch cc terms tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do +tryMatch (p,t) = do t' <- termForm t trym p t' where @@ -83,26 +84,26 @@ tryMatch (p,t) = do (PString s, ([],K i,[])) | s==i -> return [] (PInt s, ([],EInt i,[])) | s==i -> return [] (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PC p pp, ([], Con f, tt)) | + (PC p pp, ([], Con f, tt)) | p `eqStrIdent` f && length pp == length tt -> do matches <- mapM tryMatch (zip pp tt) return (concat matches) - (PP (q,p) pp, ([], QC (r,f), tt)) | + (PP (q,p) pp, ([], QC (r,f), tt)) | -- q `eqStrIdent` r && --- not for inherited AR 10/10/2005 p `eqStrIdent` f && length pp == length tt -> do matches <- mapM tryMatch (zip pp tt) return (concat matches) ---- hack for AppPredef bug - (PP (q,p) pp, ([], Q (r,f), tt)) | - -- q `eqStrIdent` r && --- + (PP (q,p) pp, ([], Q (r,f), tt)) | + -- q `eqStrIdent` r && --- p `eqStrIdent` f && length pp == length tt -> do matches <- mapM tryMatch (zip pp tt) return (concat matches) (PR r, ([],R r',[])) | all (`elem` map fst r') (map fst r) -> - do matches <- mapM tryMatch + do matches <- mapM tryMatch [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] return (concat matches) (PT _ p',_) -> trym p' t' @@ -125,7 +126,7 @@ tryMatch (p,t) = do (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s (PRep p1, ([],K s, [])) -> checks [ - trym (foldr (const (PSeq p1)) (PString "") + trym (foldr (const (PSeq p1)) (PString "") [1..n]) t' | n <- [0 .. length s] ] >> return [] diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 341dae39b..74fd511b7 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -1,365 +1,364 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Grammar.Printer --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -module GF.Grammar.Printer - ( -- ** Pretty printing - TermPrintQual(..) - , ppModule - , ppJudgement - , ppParams - , ppTerm - , ppPatt - , ppValue - , ppConstrs - , ppQIdent - , ppMeta - , getAbs - ) where -import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Grammar.Values -import GF.Grammar.Grammar - -import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq) - -import GF.Text.Pretty -import Data.Maybe (isNothing) -import Data.List (intersperse) -import qualified Data.Map as Map ---import qualified Data.IntMap as IntMap ---import qualified Data.Set as Set -import qualified Data.Array.IArray as Array - -data TermPrintQual - = Terse | Unqualified | Qualified | Internal - deriving Eq - -instance Pretty Grammar where - pp = vcat . map (ppModule Qualified) . modules - -ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = - hdr $$ - nest 2 (ppOptions opts $$ - vcat (map (ppJudgement q) (Map.toList jments)) $$ - maybe empty (ppSequences q) mseqs) $$ - ftr - where - hdr = complModDoc <+> modTypeDoc <+> '=' <+> - hsep (intersperse (pp "**") $ - filter (not . isEmpty) $ [ commaPunct ppExtends exts - , maybe empty ppWith with - , if null opens - then pp '{' - else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{' - ]) - - ftr = '}' - - complModDoc = - case mstat of - MSComplete -> empty - MSIncomplete -> pp "incomplete" - - modTypeDoc = - case mtype of - MTAbstract -> "abstract" <+> mn - MTResource -> "resource" <+> mn - MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs - MTInterface -> "interface" <+> mn - MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie - - ppExtends (id,MIAll ) = pp id - ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs) - ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs) - - ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens - -ppOptions opts = - "flags" $$ - nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts]) - -ppJudgement q (id, AbsCat pcont ) = - "cat" <+> id <+> - (case pcont of - Just (L _ cont) -> hsep (map (ppDecl q) cont) - Nothing -> empty) <+> ';' -ppJudgement q (id, AbsFun ptype _ pexp poper) = - let kind | isNothing pexp = "data" - | poper == Just False = "oper" - | otherwise = "fun" - in - (case ptype of - Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';' - Nothing -> empty) $$ - (case pexp of - Just [] -> empty - Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs] - Nothing -> empty) -ppJudgement q (id, ResParam pparams _) = - "param" <+> id <+> - (case pparams of - Just (L _ ps) -> '=' <+> ppParams q ps - _ -> empty) <+> ';' -ppJudgement q (id, ResValue pvalue) = - "-- param constructor" <+> id <+> ':' <+> - (case pvalue of - (L _ ty) -> ppTerm q 0 ty) <+> ';' -ppJudgement q (id, ResOper ptype pexp) = - "oper" <+> id <+> - (case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$ - case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';' -ppJudgement q (id, ResOverload ids defs) = - "oper" <+> id <+> '=' <+> - ("overload" <+> '{' $$ - nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$ - '}') <+> ';' -ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) = - (case pcat of - Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';' - Nothing -> empty) $$ - (case pdef of - Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' - Nothing -> empty) $$ - (case pref of - Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' - Nothing -> empty) $$ - (case pprn of - Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' - Nothing -> empty) $$ - (case (mpmcfg,q) of - (Just (PMCFG prods funs),Internal) - -> "pmcfg" <+> id <+> '=' <+> '{' $$ - nest 2 (vcat (map ppProduction prods) $$ - ' ' $$ - vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> - parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) - (Array.assocs funs))) $$ - '}' - _ -> empty) -ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) = - (case pdef of - Just (L _ e) -> let (xs,e') = getAbs e - in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';' - Nothing -> empty) $$ - (case pprn of - Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' - Nothing -> empty) $$ - (case (mpmcfg,q) of - (Just (PMCFG prods funs),Internal) - -> "pmcfg" <+> id <+> '=' <+> '{' $$ - nest 2 (vcat (map ppProduction prods) $$ - ' ' $$ - vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> - parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) - (Array.assocs funs))) $$ - '}' - _ -> empty) -ppJudgement q (id, AnyInd cann mid) = - case q of - Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';' - _ -> empty - -instance Pretty Term where pp = ppTerm Unqualified 0 - -ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) - in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e') -ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of - ([],_) -> "table" <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' - (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e) -ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' -ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' -ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' -ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit - then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b) - else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b) -ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt) -ppTerm q d (Let l e) = let (ls,e') = getLet e - in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e') -ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s) -ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2)) -ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2) -ppTerm q d (S x y) = case x of - T annot xs -> let e = case annot of - TRaw -> y - TTyped t -> Typed y t - TComp t -> Typed y t - TWild t -> Typed y t - in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' - _ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y)) -ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y) -ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) -ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))]) -ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))) -ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) -ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) -ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) -ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p) -ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t) -ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l) -ppTerm q d (Cn id) = pp id -ppTerm q d (Vr id) = pp id -ppTerm q d (Q id) = ppQIdent q id -ppTerm q d (QC id) = ppQIdent q id -ppTerm q d (Sort id) = pp id -ppTerm q d (K s) = str s -ppTerm q d (EInt n) = pp n -ppTerm q d (EFloat f) = pp f -ppTerm q d (Meta i) = ppMeta i -ppTerm q d (Empty) = pp "[]" -ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType -ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+> - fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty}, - '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) -ppTerm q d (RecType xs) - | q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of - [cat] -> pp cat - _ -> doc - | otherwise = doc - where - doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs])) -ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>' -ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) -ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t) -ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t) -ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s) - -ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e - -ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e - -instance Pretty Patt where pp = ppPatt Unqualified 0 - -ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2) -ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) -ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) -ppPatt q d (PC f ps) = if null ps - then pp f - else prec d 1 (f <+> hsep (map (ppPatt q 3) ps)) -ppPatt q d (PP f ps) = if null ps - then ppQIdent q f - else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps)) -ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*') -ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p) -ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p) -ppPatt q d (PChar) = pp '?' -ppPatt q d (PChars s) = brackets (str s) -ppPatt q d (PMacro id) = '#' <> id -ppPatt q d (PM id) = '#' <> ppQIdent q id -ppPatt q d PW = pp '_' -ppPatt q d (PV id) = pp id -ppPatt q d (PInt n) = pp n -ppPatt q d (PFloat f) = pp f -ppPatt q d (PString s) = str s -ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs])) -ppPatt q d (PImplArg p) = braces (ppPatt q 0 p) -ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t) - -ppValue :: TermPrintQual -> Int -> Val -> Doc -ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging -ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) -ppValue q d (VCn (_,c)) = pp c -ppValue q d (VClos env e) = case e of - Meta _ -> ppTerm q d e <> ppEnv env - _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging -ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs])) -ppValue q d VType = pp "Type" - -ppConstrs :: Constraints -> [Doc] -ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w)) - -ppEnv :: Env -> Doc -ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e) - -str s = doubleQuotes s - -ppDecl q (_,id,typ) - | id == identW = ppTerm q 3 typ - | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) - -ppDDecl q (_,id,typ) - | id == identW = ppTerm q 6 typ - | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) - -ppQIdent :: TermPrintQual -> QIdent -> Doc -ppQIdent q (m,id) = - case q of - Terse -> pp id - Unqualified -> pp id - Qualified -> m <> '.' <> id - Internal -> m <> '.' <> id - - -instance Pretty Label where pp = pp . label2ident - -ppOpenSpec (OSimple id) = pp id -ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n) - -ppInstSpec (id,n) = parens (id <+> '=' <+> n) - -ppLocDef q (id, (mbt, e)) = - id <+> - (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';' - -ppBind (Explicit,v) = pp v -ppBind (Implicit,v) = braces v - -ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y - -ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps)) -ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt) - -ppProduction (Production fid funid args) = - ppFId fid <+> "->" <+> ppFunId funid <> - brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args))) - -ppSequences q seqsArr - | null seqs || q /= Internal = empty - | otherwise = "sequences" <+> '{' $$ - nest 2 (vcat (map ppSeq seqs)) $$ - '}' - where - seqs = Array.assocs seqsArr - -commaPunct f ds = (hcat (punctuate "," (map f ds))) - -prec d1 d2 doc - | d1 > d2 = parens doc - | otherwise = doc - -getAbs :: Term -> ([(BindType,Ident)], Term) -getAbs (Abs bt v e) = let (xs,e') = getAbs e - in ((bt,v):xs,e') -getAbs e = ([],e) - -getCTable :: Term -> ([Ident], Term) -getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e - in (v:vs,e') -getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e - in (identW:vs,e') -getCTable e = ([],e) - -getLet :: Term -> ([LocalDef], Term) -getLet (Let l e) = let (ls,e') = getLet e - in (l:ls,e') -getLet e = ([],e) - +---------------------------------------------------------------------- +-- | +-- Module : GF.Grammar.Printer +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} +module GF.Grammar.Printer + ( -- ** Pretty printing + TermPrintQual(..) + , ppModule + , ppJudgement + , ppParams + , ppTerm + , ppPatt + , ppValue + , ppConstrs + , ppQIdent + , ppMeta + , getAbs + ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint + +import GF.Infra.Ident +import GF.Infra.Option +import GF.Grammar.Values +import GF.Grammar.Grammar + +import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq) + +import GF.Text.Pretty +import Data.Maybe (isNothing) +import Data.List (intersperse) +import qualified Data.Map as Map +--import qualified Data.IntMap as IntMap +--import qualified Data.Set as Set +import qualified Data.Array.IArray as Array + +data TermPrintQual + = Terse | Unqualified | Qualified | Internal + deriving Eq + +instance Pretty Grammar where + pp = vcat . map (ppModule Qualified) . modules + +ppModule :: TermPrintQual -> SourceModule -> Doc +ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = + hdr $$ + nest 2 (ppOptions opts $$ + vcat (map (ppJudgement q) (Map.toList jments)) $$ + maybe empty (ppSequences q) mseqs) $$ + ftr + where + hdr = complModDoc <+> modTypeDoc <+> '=' <+> + hsep (intersperse (pp "**") $ + filter (not . isEmpty) $ [ commaPunct ppExtends exts + , maybe empty ppWith with + , if null opens + then pp '{' + else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{' + ]) + + ftr = '}' + + complModDoc = + case mstat of + MSComplete -> empty + MSIncomplete -> pp "incomplete" + + modTypeDoc = + case mtype of + MTAbstract -> "abstract" <+> mn + MTResource -> "resource" <+> mn + MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs + MTInterface -> "interface" <+> mn + MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie + + ppExtends (id,MIAll ) = pp id + ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs) + ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs) + + ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens + +ppOptions opts = + "flags" $$ + nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts]) + +ppJudgement q (id, AbsCat pcont ) = + "cat" <+> id <+> + (case pcont of + Just (L _ cont) -> hsep (map (ppDecl q) cont) + Nothing -> empty) <+> ';' +ppJudgement q (id, AbsFun ptype _ pexp poper) = + let kind | isNothing pexp = "data" + | poper == Just False = "oper" + | otherwise = "fun" + in + (case ptype of + Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';' + Nothing -> empty) $$ + (case pexp of + Just [] -> empty + Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs] + Nothing -> empty) +ppJudgement q (id, ResParam pparams _) = + "param" <+> id <+> + (case pparams of + Just (L _ ps) -> '=' <+> ppParams q ps + _ -> empty) <+> ';' +ppJudgement q (id, ResValue pvalue) = + "-- param constructor" <+> id <+> ':' <+> + (case pvalue of + (L _ ty) -> ppTerm q 0 ty) <+> ';' +ppJudgement q (id, ResOper ptype pexp) = + "oper" <+> id <+> + (case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$ + case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';' +ppJudgement q (id, ResOverload ids defs) = + "oper" <+> id <+> '=' <+> + ("overload" <+> '{' $$ + nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$ + '}') <+> ';' +ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) = + (case pcat of + Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';' + Nothing -> empty) $$ + (case pdef of + Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' + Nothing -> empty) $$ + (case pref of + Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' + Nothing -> empty) $$ + (case pprn of + Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' + Nothing -> empty) $$ + (case (mpmcfg,q) of + (Just (PMCFG prods funs),Internal) + -> "pmcfg" <+> id <+> '=' <+> '{' $$ + nest 2 (vcat (map ppProduction prods) $$ + ' ' $$ + vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> + parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) + (Array.assocs funs))) $$ + '}' + _ -> empty) +ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) = + (case pdef of + Just (L _ e) -> let (xs,e') = getAbs e + in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';' + Nothing -> empty) $$ + (case pprn of + Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' + Nothing -> empty) $$ + (case (mpmcfg,q) of + (Just (PMCFG prods funs),Internal) + -> "pmcfg" <+> id <+> '=' <+> '{' $$ + nest 2 (vcat (map ppProduction prods) $$ + ' ' $$ + vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> + parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) + (Array.assocs funs))) $$ + '}' + _ -> empty) +ppJudgement q (id, AnyInd cann mid) = + case q of + Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';' + _ -> empty + +instance Pretty Term where pp = ppTerm Unqualified 0 + +ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) + in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e') +ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of + ([],_) -> "table" <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' + (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e) +ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' +ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' +ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' +ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit + then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b) + else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b) +ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt) +ppTerm q d (Let l e) = let (ls,e') = getLet e + in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e') +ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s) +ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2)) +ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2) +ppTerm q d (S x y) = case x of + T annot xs -> let e = case annot of + TRaw -> y + TTyped t -> Typed y t + TComp t -> Typed y t + TWild t -> Typed y t + in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' + _ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y)) +ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y) +ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) +ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))]) +ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))) +ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) +ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) +ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) +ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p) +ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t) +ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l) +ppTerm q d (Cn id) = pp id +ppTerm q d (Vr id) = pp id +ppTerm q d (Q id) = ppQIdent q id +ppTerm q d (QC id) = ppQIdent q id +ppTerm q d (Sort id) = pp id +ppTerm q d (K s) = str s +ppTerm q d (EInt n) = pp n +ppTerm q d (EFloat f) = pp f +ppTerm q d (Meta i) = ppMeta i +ppTerm q d (Empty) = pp "[]" +ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType +ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+> + fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty}, + '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) +ppTerm q d (RecType xs) + | q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of + [cat] -> pp cat + _ -> doc + | otherwise = doc + where + doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs])) +ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>' +ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) +ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t) +ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t) +ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s) + +ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e + +ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e + +instance Pretty Patt where pp = ppPatt Unqualified 0 + +ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2) +ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) +ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) +ppPatt q d (PC f ps) = if null ps + then pp f + else prec d 1 (f <+> hsep (map (ppPatt q 3) ps)) +ppPatt q d (PP f ps) = if null ps + then ppQIdent q f + else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps)) +ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*') +ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p) +ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p) +ppPatt q d (PChar) = pp '?' +ppPatt q d (PChars s) = brackets (str s) +ppPatt q d (PMacro id) = '#' <> id +ppPatt q d (PM id) = '#' <> ppQIdent q id +ppPatt q d PW = pp '_' +ppPatt q d (PV id) = pp id +ppPatt q d (PInt n) = pp n +ppPatt q d (PFloat f) = pp f +ppPatt q d (PString s) = str s +ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs])) +ppPatt q d (PImplArg p) = braces (ppPatt q 0 p) +ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t) + +ppValue :: TermPrintQual -> Int -> Val -> Doc +ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging +ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) +ppValue q d (VCn (_,c)) = pp c +ppValue q d (VClos env e) = case e of + Meta _ -> ppTerm q d e <> ppEnv env + _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging +ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs])) +ppValue q d VType = pp "Type" + +ppConstrs :: Constraints -> [Doc] +ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w)) + +ppEnv :: Env -> Doc +ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e) + +str s = doubleQuotes s + +ppDecl q (_,id,typ) + | id == identW = ppTerm q 3 typ + | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) + +ppDDecl q (_,id,typ) + | id == identW = ppTerm q 6 typ + | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) + +ppQIdent :: TermPrintQual -> QIdent -> Doc +ppQIdent q (m,id) = + case q of + Terse -> pp id + Unqualified -> pp id + Qualified -> m <> '.' <> id + Internal -> m <> '.' <> id + + +instance Pretty Label where pp = pp . label2ident + +ppOpenSpec (OSimple id) = pp id +ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n) + +ppInstSpec (id,n) = parens (id <+> '=' <+> n) + +ppLocDef q (id, (mbt, e)) = + id <+> + (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';' + +ppBind (Explicit,v) = pp v +ppBind (Implicit,v) = braces v + +ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y + +ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps)) +ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt) + +ppProduction (Production fid funid args) = + ppFId fid <+> "->" <+> ppFunId funid <> + brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args))) + +ppSequences q seqsArr + | null seqs || q /= Internal = empty + | otherwise = "sequences" <+> '{' $$ + nest 2 (vcat (map ppSeq seqs)) $$ + '}' + where + seqs = Array.assocs seqsArr + +commaPunct f ds = (hcat (punctuate "," (map f ds))) + +prec d1 d2 doc + | d1 > d2 = parens doc + | otherwise = doc + +getAbs :: Term -> ([(BindType,Ident)], Term) +getAbs (Abs bt v e) = let (xs,e') = getAbs e + in ((bt,v):xs,e') +getAbs e = ([],e) + +getCTable :: Term -> ([Ident], Term) +getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e + in (v:vs,e') +getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e + in (identW:vs,e') +getCTable e = ([],e) + +getLet :: Term -> ([LocalDef], Term) +getLet (Let l e) = let (ls,e') = getLet e + in (l:ls,e') +getLet e = ([],e) diff --git a/src/compiler/GF/Grammar/Values.hs b/src/compiler/GF/Grammar/Values.hs index 3cfd79ad7..c8fcb3945 100644 --- a/src/compiler/GF/Grammar/Values.hs +++ b/src/compiler/GF/Grammar/Values.hs @@ -5,22 +5,23 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:22:32 $ +-- > CVS $Date: 2005/04/21 16:22:32 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.7 $ -- -- (Description of the module) ----------------------------------------------------------------------------- -module GF.Grammar.Values (-- ** Values used in TC type checking - Val(..), Env, - -- ** Annotated tree used in editing +module GF.Grammar.Values ( + -- ** Values used in TC type checking + Val(..), Env, + -- ** Annotated tree used in editing Binds, Constraints, MetaSubst, - -- ** For TC - valAbsInt, valAbsFloat, valAbsString, vType, - isPredefCat, - eType, - ) where + -- ** For TC + valAbsInt, valAbsFloat, valAbsString, vType, + isPredefCat, + eType, + ) where import GF.Infra.Ident import GF.Grammar.Grammar diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index c0234999a..a5ff7148a 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:22:33 $ +-- > CVS $Date: 2005/04/21 16:22:33 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.5 $ -- @@ -14,10 +14,10 @@ module GF.Infra.CheckM (Check, CheckResult, Message, runCheck, runCheck', - checkError, checkCond, checkWarn, checkWarnings, checkAccumError, - checkIn, checkInModule, checkMap, checkMapRecover, + checkError, checkCond, checkWarn, checkWarnings, checkAccumError, + checkIn, checkInModule, checkMap, checkMapRecover, parallelCheck, accumulateError, commitCheck, - ) where + ) where import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Data.Operations @@ -141,10 +141,10 @@ checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList where f' (k,v) = fmap ((,)k) (f k v) {- -checkMapRecover f mp = do +checkMapRecover f mp = do let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp) case [s | (_,Bad s) <- xs] of - ss@(_:_) -> checkError (text (unlines ss)) + ss@(_:_) -> checkError (text (unlines ss)) _ -> do let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs] if not (all null ss) then checkWarn (text (unlines ss)) else return () diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs index b856d3995..ad47d91cd 100644 --- a/src/compiler/GF/Infra/Ident.hs +++ b/src/compiler/GF/Infra/Ident.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/15 11:43:33 $ +-- > CVS $Date: 2005/11/15 11:43:33 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.8 $ -- @@ -13,18 +13,18 @@ ----------------------------------------------------------------------------- module GF.Infra.Ident (-- ** Identifiers - ModuleName(..), moduleNameS, - Ident, ident2utf8, showIdent, prefixIdent, - -- *** Normal identifiers (returned by the parser) - identS, identC, identW, - -- *** Special identifiers for internal use - identV, identA, identAV, - argIdent, isArgIdent, getArgIndex, - varStr, varX, isWildIdent, varIndex, - -- *** Raw identifiers - RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent, - isPrefixOf, showRawIdent - ) where + ModuleName(..), moduleNameS, + Ident, ident2utf8, showIdent, prefixIdent, + -- *** Normal identifiers (returned by the parser) + identS, identC, identW, + -- *** Special identifiers for internal use + identV, identA, identAV, + argIdent, isArgIdent, getArgIndex, + varStr, varX, isWildIdent, varIndex, + -- *** Raw identifiers + RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent, + isPrefixOf, showRawIdent +) where import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Char8 as BS(append,isPrefixOf) @@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m -- | the constructors labelled /INTERNAL/ are -- internal representation never returned by the parser -data Ident = +data Ident = IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename | IW -- ^ wildcard -- @@ -54,7 +54,7 @@ data Ident = | IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable | IA {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position --- +-- deriving (Eq, Ord, Show, Read) -- | Identifiers are stored as UTF-8-encoded bytestrings. @@ -70,14 +70,13 @@ rawIdentS = Id . pack rawIdentC = Id showRawIdent = unpack . rawId2utf8 -prefixRawIdent (Id x) (Id y) = Id (BS.append x y) +prefixRawIdent (Id x) (Id y) = Id (BS.append x y) isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y instance Binary RawIdent where put = put . rawId2utf8 get = fmap rawIdentC get - -- | This function should be used with care, since the returned ByteString is -- UTF-8-encoded. ident2utf8 :: Ident -> UTF8.ByteString @@ -88,6 +87,7 @@ ident2utf8 i = case i of IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j)) IW -> pack "_" +ident2raw :: Ident -> RawIdent ident2raw = Id . ident2utf8 showIdent :: Ident -> String @@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i instance Pretty Ident where pp = pp . showIdent +instance Pretty RawIdent where pp = pp . showRawIdent + identS :: String -> Ident identS = identC . rawIdentS identC :: RawIdent -> Ident identW :: Ident - prefixIdent :: String -> Ident -> Ident prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8 @@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident identA :: RawIdent -> Int -> Ident identAV:: RawIdent -> Int -> Int -> Ident -(identC, identV, identA, identAV, identW) = +(identC, identV, identA, identAV, identW) = (IC, IV, IA, IAV, IW) -- | to mark argument variables diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 6b7ff0cad..2a2ffd176 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -2,13 +2,13 @@ module GF.Infra.Option ( -- ** Command line options -- *** Option types - Options, - Flags(..), - Mode(..), Phase(..), Verbosity(..), - OutputFormat(..), + Options, + Flags(..), + Mode(..), Phase(..), Verbosity(..), + OutputFormat(..), SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..), Dump(..), Pass(..), Recomp(..), - outputFormatsExpl, + outputFormatsExpl, -- *** Option parsing parseOptions, parseModuleOptions, fixRelativeLibPaths, -- *** Option pretty-printing @@ -47,7 +47,7 @@ import PGF.Internal(Literal(..)) import qualified Control.Monad.Fail as Fail usageHeader :: String -usageHeader = unlines +usageHeader = unlines ["Usage: gf [OPTIONS] [FILE [...]]", "", "How each FILE is handled depends on the file name suffix:", @@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link data OutputFormat = FmtPGFPretty | FmtCanonicalGF | FmtCanonicalJson - | FmtJavaScript + | FmtJavaScript | FmtJSON - | FmtPython - | FmtHaskell + | FmtPython + | FmtHaskell | FmtJava | FmtProlog | FmtBNF @@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty | FmtNoLR | FmtSRGS_XML | FmtSRGS_XML_NonRec - | FmtSRGS_ABNF + | FmtSRGS_ABNF | FmtSRGS_ABNF_NonRec - | FmtJSGF - | FmtGSL + | FmtJSGF + | FmtGSL | FmtVoiceXML | FmtSLF | FmtRegExp | FmtFA deriving (Eq,Ord) -data SISRFormat = +data SISRFormat = -- | SISR Working draft 1 April 2003 -- - SISR_WD20030401 + SISR_WD20030401 | SISR_1_0 deriving (Show,Eq,Ord) data Optimization = OptStem | OptCSE | OptExpand | OptParametrize deriving (Show,Eq,Ord) -data CFGTransform = CFGNoLR +data CFGTransform = CFGNoLR | CFGRegular - | CFGTopDownFilter - | CFGBottomUpFilter + | CFGTopDownFilter + | CFGBottomUpFilter | CFGStartCatOnly | CFGMergeIdentical | CFGRemoveCycles deriving (Show,Eq,Ord) -data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical - | HaskellConcrete | HaskellVariants | HaskellData +data HaskellOption = HaskellNoPrefix + | HaskellGADT + | HaskellLexical + | HaskellConcrete + | HaskellVariants + | HaskellData + | HaskellPGF2 deriving (Show,Eq,Ord) data Warning = WarnMissingLincat @@ -196,7 +201,7 @@ instance Show Options where parseOptions :: ErrorMonad err => [String] -- ^ list of string arguments -> err (Options, [FilePath]) -parseOptions args +parseOptions args | not (null errs) = errors errs | otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss) return (opts, files) @@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err => -> err Options parseModuleOptions args = do (opts,nonopts) <- parseOptions args - if null nonopts + if null nonopts then return opts else errors $ map ("Non-option among module options: " ++) nonopts @@ -281,7 +286,7 @@ defaultFlags = Flags { optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize], optOptimizePGF = False, optSplitPGF = False, - optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, + optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, CFGTopDownFilter, CFGMergeIdentical], optLibraryPath = [], optStartCat = Nothing, @@ -301,7 +306,7 @@ defaultFlags = Flags { -- | Option descriptions {-# NOINLINE optDescr #-} optDescr :: [OptDescr (Err Options)] -optDescr = +optDescr = [ Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.", Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.", @@ -327,44 +332,44 @@ optDescr = -- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations", -- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations", Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", - Option ['f'] ["output-format"] (ReqArg outFmt "FMT") + Option ['f'] ["output-format"] (ReqArg outFmt "FMT") (unlines ["Output format. FMT can be one of:", "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)", "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar, "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf, "Abstract only: haskell, ..."]), -- prolog_abs, - Option [] ["sisr"] (ReqArg sisrFmt "FMT") + Option [] ["sisr"] (ReqArg sisrFmt "FMT") (unlines ["Include SISR tags in generated speech recognition grammars.", "FMT can be one of: old, 1.0"]), - Option [] ["haskell"] (ReqArg hsOption "OPTION") - ("Turn on an optional feature when generating Haskell data types. OPTION = " + Option [] ["haskell"] (ReqArg hsOption "OPTION") + ("Turn on an optional feature when generating Haskell data types. OPTION = " ++ concat (intersperse " | " (map fst haskellOptionNames))), - Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") + Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") "Treat CAT as a lexical category.", - Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") + Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") "Treat CAT as a literal category.", - Option ['D'] ["output-dir"] (ReqArg outDir "DIR") + Option ['D'] ["output-dir"] (ReqArg outDir "DIR") "Save output files (other than .gfo files) in DIR.", - Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") + Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") "Overrides the value of GF_LIB_PATH.", - Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) + Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) "Always recompile from source.", - Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer)) + Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer)) "(default) Recompile from source if the source is newer than the .gfo file.", - Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) + Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) "Never recompile from source, if there is already .gfo file.", Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.", - Option ['n'] ["name"] (ReqArg name "NAME") + Option ['n'] ["name"] (ReqArg name "NAME") (unlines ["Use NAME as the name of the output. This is used in the output file names, ", "with suffixes depending on the formats, and, when relevant, ", "internally in the output."]), Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.", Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.", - Option [] ["preproc"] (ReqArg preproc "CMD") + Option [] ["preproc"] (ReqArg preproc "CMD") (unlines ["Use CMD to preprocess input files.", "Multiple preprocessors can be used by giving this option multiple times."]), - Option [] ["coding"] (ReqArg coding "ENCODING") + Option [] ["coding"] (ReqArg coding "ENCODING") ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."), Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.", Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.", @@ -372,7 +377,7 @@ optDescr = Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.", Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).", Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).", - Option [] ["optimize"] (ReqArg optimize "OPT") + Option [] ["optimize"] (ReqArg optimize "OPT") "Select an optimization package. OPT = all | values | parametrize | none", Option [] ["optimize-pgf"] (NoArg (optimize_pgf True)) "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file", @@ -447,7 +452,7 @@ optDescr = optimize x = case lookup x optimizationPackages of Just p -> set $ \o -> o { optOptimizations = p } Nothing -> fail $ "Unknown optimization package: " ++ x - + optimize_pgf x = set $ \o -> o { optOptimizePGF = x } splitPGF x = set $ \o -> o { optSplitPGF = x } @@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)] outputFormats = map fst outputFormatsExpl outputFormatsExpl :: [((String,OutputFormat),String)] -outputFormatsExpl = +outputFormatsExpl = [(("pgf_pretty", FmtPGFPretty),"human-readable pgf"), (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"), (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"), @@ -504,11 +509,11 @@ instance Read OutputFormat where readsPrec = lookupReadsPrec outputFormats optimizationPackages :: [(String, Set Optimization)] -optimizationPackages = +optimizationPackages = [("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("values", Set.fromList [OptStem,OptCSE,OptExpand]), ("noexpand", Set.fromList [OptStem,OptCSE]), - + -- deprecated ("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]), @@ -516,7 +521,7 @@ optimizationPackages = ] cfgTransformNames :: [(String, CFGTransform)] -cfgTransformNames = +cfgTransformNames = [("nolr", CFGNoLR), ("regular", CFGRegular), ("topdown", CFGTopDownFilter), @@ -532,7 +537,8 @@ haskellOptionNames = ("lexical", HaskellLexical), ("concrete", HaskellConcrete), ("variants", HaskellVariants), - ("data", HaskellData)] + ("data", HaskellData), + ("pgf2", HaskellPGF2)] -- | This is for bacward compatibility. Since GHC 6.12 we -- started using the native Unicode support in GHC but it @@ -558,7 +564,7 @@ onOff f def = OptArg g "[on,off]" _ -> fail $ "Expected [on,off], got: " ++ show x readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat -readOutputFormat s = +readOutputFormat s = maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats -- FIXME: this is a copy of the function in GF.Devel.UseIO. @@ -570,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of isPathSep :: Char -> Bool isPathSep c = c == ':' || c == ';' --- +-- -- * Convenience functions for checking options -- @@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts) isLexicalCat :: Options -> String -> Bool isLexicalCat opts c = Set.member c (flag optLexicalCats opts) --- +-- -- * Convenience functions for setting options -- @@ -623,8 +629,8 @@ readMaybe s = case reads s of toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a toEnumBounded i = let mi = minBound - ma = maxBound `asTypeOf` mi - in if i >= fromEnum mi && i <= fromEnum ma + ma = maxBound `asTypeOf` mi + in if i >= fromEnum mi && i <= fromEnum ma then Just (toEnum i `asTypeOf` mi) else Nothing diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 9987b7c39..1ea62e4b3 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -38,7 +38,6 @@ import GF.Server(server) #endif import GF.Command.Messages(welcome) -import GF.Infra.UseIO (Output) -- Provides an orphan instance of MonadFail for StateT in ghc versions < 8 import Control.Monad.Trans.Instances () @@ -56,6 +55,7 @@ mainGFI opts files = do shell opts files = flip evalStateT (emptyGFEnv opts) $ do mapStateT runSIO $ importInEnv opts files + modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]} loop #ifdef SERVER_MODE @@ -433,7 +433,7 @@ wc_type = cmd_name x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of - [x] -> Just x + [x] -> Just x _ -> Nothing isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/compiler/GF/Interactive2.hs b/src/compiler/GF/Interactive2.hs index 02e42e19e..d429b4530 100644 --- a/src/compiler/GF/Interactive2.hs +++ b/src/compiler/GF/Interactive2.hs @@ -58,6 +58,7 @@ mainGFI opts files = do shell opts files = flip evalStateT (emptyGFEnv opts) $ do mapStateT runSIO $ importInEnv opts files + modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]} loop {- @@ -101,7 +102,7 @@ timeIt act = -- | Optionally show how much CPU time was used to run an IO action optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a -optionallyShowCPUTime opts act +optionallyShowCPUTime opts act | not (verbAtLeast opts Normal) = act | otherwise = do (dt,r) <- timeIt act liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec" @@ -358,7 +359,7 @@ wordCompletion gfenv (left,right) = do CmplIdent _ pref -> case mb_pgf of Just pgf -> ret (length pref) - [Haskeline.simpleCompletion name + [Haskeline.simpleCompletion name | name <- C.functions pgf, isPrefixOf pref name] _ -> ret (length pref) [] @@ -369,7 +370,7 @@ wordCompletion gfenv (left,right) = do cmdEnv = commandenv gfenv {- optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts - optType opts = + optType opts = let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts in case H.readType str of Just ty -> ty @@ -416,7 +417,7 @@ wc_type = cmd_name option x y (c :cs) | isIdent c = option x y cs | otherwise = cmd x cs - + optValue x y ('"':cs) = str x y cs optValue x y cs = cmd x cs @@ -434,9 +435,9 @@ wc_type = cmd_name where x1 = take (length x - length y - d) x x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 - + cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of - [x] -> Just x + [x] -> Just x _ -> Nothing isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/compiler/GF/Main.hs b/src/compiler/GF/Main.hs index 7cde1ce97..7d4500c7b 100644 --- a/src/compiler/GF/Main.hs +++ b/src/compiler/GF/Main.hs @@ -16,18 +16,19 @@ import Data.Version import System.Directory import System.Environment (getArgs) import System.Exit -import GF.System.Console (setConsoleEncoding) +-- import GF.System.Console (setConsoleEncoding) -- | Run the GF main program, taking arguments from the command line. -- (It calls 'setConsoleEncoding' and 'getOptions', then 'mainOpts'.) -- Run @gf --help@ for usage info. main :: IO () main = do - --setConsoleEncoding + -- setConsoleEncoding uncurry mainOpts =<< getOptions -- | Get and parse GF command line arguments. Fix relative paths. -- Calls 'getArgs' and 'parseOptions'. +getOptions :: IO (Options, [FilePath]) getOptions = do args <- getArgs case parseOptions args of @@ -43,7 +44,7 @@ getOptions = do -- the options it invokes 'mainGFC', 'mainGFI', 'mainRunGFI', 'mainServerGFI', -- or it just prints version/usage info. mainOpts :: Options -> [FilePath] -> IO () -mainOpts opts files = +mainOpts opts files = case flag optMode opts of ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo ModeHelp -> putStrLn helpMessage diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index c287e8001..2e8b8b056 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -6,7 +6,7 @@ import qualified Data.Map as M import Control.Applicative -- for GHC<7.10 import Control.Monad(when) import Control.Monad.State(StateT(..),get,gets,put) -import Control.Monad.Error(ErrorT(..),Error(..)) +import Control.Monad.Except(ExceptT(..),runExceptT) import System.Random(randomRIO) --import System.IO(stderr,hPutStrLn) import GF.System.Catch(try) @@ -108,9 +108,9 @@ handle_fcgi execute1 state0 stateM cache = -- * Request handler -- | Handler monad -type HM s a = StateT (Q,s) (ErrorT Response IO) a +type HM s a = StateT (Q,s) (ExceptT Response IO) a run :: HM s Response -> (Q,s) -> IO (s,Response) -run m s = either bad ok =<< runErrorT (runStateT m s) +run m s = either bad ok =<< runExceptT (runStateT m s) where bad resp = return (snd s,resp) ok (resp,(qs,state)) = return (state,resp) @@ -123,12 +123,12 @@ put_qs qs = do state <- get_state; put (qs,state) put_state state = do qs <- get_qs; put (qs,state) err :: Response -> HM s a -err e = StateT $ \ s -> ErrorT $ return $ Left e +err e = StateT $ \ s -> ExceptT $ return $ Left e hmbracket_ :: IO () -> IO () -> HM s a -> HM s a hmbracket_ pre post m = do s <- get - e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s + e <- liftIO $ bracket_ pre post $ runExceptT $ runStateT m s case e of Left resp -> err resp Right (a,s) -> do put s;return a @@ -407,9 +407,6 @@ resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n" resp500 msg = Response 500 [plain,xo] $ "Internal error: "++msg++"\n" resp501 msg = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n" -instance Error Response where - noMsg = resp500 "no message" - strMsg = resp500 -- * Content types plain = ct "text/plain" "" diff --git a/src/compiler/GF/Speech/FiniteState.hs b/src/compiler/GF/Speech/FiniteState.hs index cb5247755..95acd35c5 100644 --- a/src/compiler/GF/Speech/FiniteState.hs +++ b/src/compiler/GF/Speech/FiniteState.hs @@ -5,37 +5,37 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/10 16:43:44 $ +-- > CVS $Date: 2005/11/10 16:43:44 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.16 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- module GF.Speech.FiniteState (FA(..), State, NFA, DFA, - startState, finalStates, - states, transitions, + startState, finalStates, + states, transitions, isInternal, - newFA, newFA_, - addFinalState, - newState, newStates, + newFA, newFA_, + addFinalState, + newState, newStates, newTransition, newTransitions, insertTransitionWith, insertTransitionsWith, - mapStates, mapTransitions, + mapStates, mapTransitions, modifyTransitions, - nonLoopTransitionsTo, nonLoopTransitionsFrom, + nonLoopTransitionsTo, nonLoopTransitionsFrom, loops, removeState, oneFinalState, insertNFA, onGraph, - moveLabelsToNodes, removeTrivialEmptyNodes, + moveLabelsToNodes, removeTrivialEmptyNodes, minimize, dfa2nfa, unusedNames, renameStates, - prFAGraphviz, faToGraphviz) where + prFAGraphviz, faToGraphviz) where import Data.List -import Data.Maybe +import Data.Maybe --import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l)) newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b newTransitions es = onGraph (newEdges es) -insertTransitionWith :: Eq n => +insertTransitionWith :: Eq n => (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b insertTransitionWith f t = onGraph (insertEdgeWith f t) -insertTransitionsWith :: Eq n => +insertTransitionsWith :: Eq n => (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b -insertTransitionsWith f ts fa = +insertTransitionsWith f ts fa = foldl' (flip (insertTransitionWith f)) fa ts mapStates :: (a -> c) -> FA n a b -> FA n c b @@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names -- | Gets all incoming transitions to a given state, excluding -- transtions from the state itself. nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsTo s fa = +nonLoopTransitionsTo s fa = [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s] nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsFrom s fa = +nonLoopTransitionsFrom s fa = [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s] loops :: Eq n => n -> FA n a b -> [b] @@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs' where (ns,rest) = splitAt (length (nodes g)) supply newNodes = Map.fromList (zip (map fst (nodes g)) ns) - newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes + newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes s' = newName s fs' = map newName fs @@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into -> (State, State) -- ^ States to insert between -> NFA a -- ^ NFA to insert. -> NFA a -insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) +insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) = FA (newEdges es g') s1 fs1 - where + where es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2] (g',ren) = mergeGraphs g1 g2 @@ -182,9 +182,9 @@ oneFinalState nl el fa = moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) () moveLabelsToNodes = onGraph f where f g@(Graph c _ _) = Graph c' ns (concat ess) - where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)] - (c',is') = mapAccumL fixIncoming c is - (ns,ess) = unzip (concat is') + where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)] + (c',is') = mapAccumL fixIncoming c is + (ns,ess) = unzip (concat is') -- | Remove empty nodes which are not start or final, and have @@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes -- This is not done if the pointed-to node is a final node. skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () skipSimpleEmptyNodes fa = onGraph og fa - where + where og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es') where es' = concatMap changeEdge es info = nodeInfo g - changeEdge e@(f,t,()) + changeEdge e@(f,t,()) | isNothing (getNodeLabel info t) -- && (i * o <= i + o) && not (isFinal fa t) @@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa where f g = if Set.null rns then g else f (removeNodes rns g) where info = nodeInfo g - rns = Set.fromList [ n | (n,_) <- nodes g, + rns = Set.fromList [ n | (n,_) <- nodes g, isInternal fa n, - inDegree info n == 0 + inDegree info n == 0 || outDegree info n == 0] -fixIncoming :: (Ord n, Eq a) => [n] +fixIncoming :: (Ord n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their -- incoming edges. fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts) where ls = nub $ map edgeLabel es - (cs',cs'') = splitAt (length ls) cs - newNodes = zip cs' ls - es' = [ (x,n,()) | x <- map fst newNodes ] - -- separate cyclic and non-cyclic edges - (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es - -- keep all incoming non-cyclic edges with the right label - to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l'] - -- for each cyclic edge with the right label, - -- add an edge from each of the new nodes (including this one) - ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] - newContexts = [ (v, to v) | v <- newNodes ] + (cs',cs'') = splitAt (length ls) cs + newNodes = zip cs' ls + es' = [ (x,n,()) | x <- map fst newNodes ] + -- separate cyclic and non-cyclic edges + (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es + -- keep all incoming non-cyclic edges with the right label + to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l'] + -- for each cyclic edge with the right label, + -- add an edge from each of the new nodes (including this one) + ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] + newContexts = [ (v, to v) | v <- newNodes ] --alphabet :: Eq b => Graph n a (Maybe b) -> [b] --alphabet = nub . catMaybes . map edgeLabel . edges @@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp (ns',es') = (Set.toList ns, Set.toList es) final = filter isDFAFinal ns' fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final - in renameStates [0..] fa + in renameStates [0..] fa where info = nodeInfo g -- reach = nodesReachable out - start = closure info $ Set.singleton s + start = closure info $ Set.singleton s isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n)) - h currentStates oldStates es - | Set.null currentStates = (oldStates,es) - | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es' - where - allOldStates = oldStates `Set.union` currentStates + h currentStates oldStates es + | Set.null currentStates = (oldStates,es) + | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es' + where + allOldStates = oldStates `Set.union` currentStates (newStates,es') = new (Set.toList currentStates) Set.empty es - uniqueNewStates = newStates Set.\\ allOldStates - -- Get the sets of states reachable from the given states + uniqueNewStates = newStates Set.\\ allOldStates + -- Get the sets of states reachable from the given states -- by consuming one symbol, and the associated edges. new [] rs es = (rs,es) new (n:ns) rs es = new ns rs' es' @@ -281,7 +281,7 @@ closure info x = closure_ x x where closure_ acc check | Set.null check = acc | otherwise = closure_ acc' check' where - reach = Set.fromList [y | x <- Set.toList check, + reach = Set.fromList [y | x <- Set.toList check, (_,y,Nothing) <- getOutgoing info x] acc' = acc `Set.union` reach check' = reach Set.\\ acc @@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y, reverseNFA :: NFA a -> NFA a reverseNFA (FA g s fs) = FA g''' s' [s] where g' = reverseGraph g - (g'',s') = newNode () g' - g''' = newEdges [(s',f,Nothing) | f <- fs] g'' + (g'',s') = newNode () g' + g''' = newEdges [(s',f,Nothing) | f <- fs] g'' dfa2nfa :: DFA a -> NFA a dfa2nfa = mapTransitions Just @@ -313,13 +313,13 @@ prFAGraphviz = Dot.prGraphviz . faToGraphviz --prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph -faToGraphviz (FA (Graph _ ns es) s f) +faToGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) [] where mkNode (n,l) = Dot.Node (show n) attrs - where attrs = [("label",l)] - ++ if n == s then [("shape","box")] else [] - ++ if n `elem` f then [("style","bold")] else [] - mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] + where attrs = [("label",l)] + ++ if n == s then [("shape","box")] else [] + ++ if n `elem` f then [("style","bold")] else [] + mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] -- -- * Utilities diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs index a898a4bb5..ceaf86ae0 100644 --- a/src/compiler/GF/Speech/GSL.hs +++ b/src/compiler/GF/Speech/GSL.hs @@ -26,14 +26,14 @@ width = 75 gslPrinter :: Options -> PGF -> CId -> String gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc - where st = style { lineLength = width } + where st = style { lineLength = width } prGSL :: SRG -> Doc prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) where header = ";GSL2.0" $$ - comment ("Nuance speech recognition grammar for " ++ srgName srg) $$ - comment ("Generated by GF") + comment ("Nuance speech recognition grammar for " ++ srgName srg) $$ + comment ("Generated by GF") mainCat = ".MAIN" <+> prCat (srgStartCat srg) prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs) -- FIXME: use the probability diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs index 15f5ff69d..b12fb0ace 100644 --- a/src/compiler/GF/Speech/JSGF.hs +++ b/src/compiler/GF/Speech/JSGF.hs @@ -31,7 +31,7 @@ width :: Int width = 75 jsgfPrinter :: Options - -> PGF + -> PGF -> CId -> String jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc where st = style { lineLength = width } @@ -44,7 +44,7 @@ prJSGF sisr srg header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$ comment ("JSGF speech recognition grammar for " ++ srgName srg) $$ comment "Generated by GF" $$ - ("grammar " ++ srgName srg ++ ";") + ("grammar " ++ srgName srg ++ ";") lang = maybe empty pp (srgLanguage srg) mainCat = rule True "MAIN" [prCat (srgStartCat srg)] prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) @@ -62,7 +62,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc prItem sisr t = f 0 where f _ (REUnion []) = pp "" - f p (REUnion xs) + f p (REUnion xs) | not (null es) = brackets (f 0 (REUnion nes)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) where (es,nes) = partition isEpsilon xs @@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs ($++$) :: Doc -> Doc -> Doc x $++$ y = x $$ emptyLine $$ y - diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs index a8ecec27d..fdd8a6c84 100644 --- a/src/compiler/GF/Speech/PGFToCFG.hs +++ b/src/compiler/GF/Speech/PGFToCFG.hs @@ -28,7 +28,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc type Profile = [Int] -pgfToCFG :: PGF +pgfToCFG :: PGF -> CId -- ^ Concrete syntax name -> CFG pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules) @@ -40,8 +40,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co , prod <- Set.toList set] fcatCats :: Map FId Cat - fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) - | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), + fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) + | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), (fc,i) <- zip (range (s,e)) [1..]] fcatCat :: FId -> Cat @@ -58,7 +58,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co topdownRules cat = f cat [] where f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc)) - + g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules g (PCoerce cat) rules = f cat rules @@ -67,13 +67,13 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co extCats = Set.fromList $ map ruleLhs startRules startRules :: [CFRule] - startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) - | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), + startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) + | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), fc <- range (s,e), not (isPredefFId fc), r <- [0..catLinArity fc-1]] ruleToCFRule :: (FId,Production) -> [CFRule] - ruleToCFRule (c,PApply funid args) = + ruleToCFRule (c,PApply funid args) = [Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]]) | (l,seqid) <- Array.assocs rhs , let row = sequences cnc ! seqid @@ -106,7 +106,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co fixProfile row i = [k | (k,j) <- nts, j == i] where nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt] - + getPos (SymCat j _) = [j] getPos (SymLit j _) = [j] getPos _ = [] diff --git a/src/compiler/GF/Speech/SRG.hs b/src/compiler/GF/Speech/SRG.hs index 9d51e52e9..b761c45cd 100644 --- a/src/compiler/GF/Speech/SRG.hs +++ b/src/compiler/GF/Speech/SRG.hs @@ -2,8 +2,8 @@ -- | -- Module : SRG -- --- Representation of, conversion to, and utilities for --- printing of a general Speech Recognition Grammar. +-- Representation of, conversion to, and utilities for +-- printing of a general Speech Recognition Grammar. -- -- FIXME: remove \/ warn \/ fail if there are int \/ string literal -- categories in the grammar @@ -40,20 +40,20 @@ import qualified Data.Set as Set --import Debug.Trace data SRG = SRG { srgName :: String -- ^ grammar name - , srgStartCat :: Cat -- ^ start category name - , srgExternalCats :: Set Cat - , srgLanguage :: Maybe String -- ^ The language for which the grammar - -- is intended, e.g. en-UK - , srgRules :: [SRGRule] - } - deriving (Eq,Show) + , srgStartCat :: Cat -- ^ start category name + , srgExternalCats :: Set Cat + , srgLanguage :: Maybe String -- ^ The language for which the grammar + -- is intended, e.g. en-UK + , srgRules :: [SRGRule] + } + deriving (Eq,Show) data SRGRule = SRGRule Cat [SRGAlt] - deriving (Eq,Show) + deriving (Eq,Show) -- | maybe a probability, a rule name and an EBNF right-hand side data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem - deriving (Eq,Show) + deriving (Eq,Show) type SRGItem = RE SRGSymbol @@ -65,7 +65,7 @@ type SRGNT = (Cat, Int) ebnfPrinter :: Options -> PGF -> CId -> String ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc --- | Create a compact filtered non-left-recursive SRG. +-- | Create a compact filtered non-left-recursive SRG. makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG makeNonLeftRecursiveSRG opts = makeSRG opts' where @@ -76,11 +76,11 @@ makeSRG opts = mkSRG cfgToSRG preprocess where cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg] preprocess = maybeTransform opts CFGMergeIdentical mergeIdentical - . maybeTransform opts CFGNoLR removeLeftRecursion + . maybeTransform opts CFGNoLR removeLeftRecursion . maybeTransform opts CFGRegular makeRegular . maybeTransform opts CFGTopDownFilter topDownFilter . maybeTransform opts CFGBottomUpFilter bottomUpFilter - . maybeTransform opts CFGRemoveCycles removeCycles + . maybeTransform opts CFGRemoveCycles removeCycles . maybeTransform opts CFGStartCatOnly purgeExternalCats setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options @@ -95,7 +95,7 @@ stats g = "Categories: " ++ show (countCats g) ++ ", External categories: " ++ show (Set.size (cfgExternalCats g)) ++ ", Rules: " ++ show (countRules g) -} -makeNonRecursiveSRG :: Options +makeNonRecursiveSRG :: Options -> PGF -> CId -- ^ Concrete syntax name. -> SRG @@ -111,26 +111,26 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG mkSRG mkRules preprocess pgf cnc = SRG { srgName = showCId cnc, - srgStartCat = cfgStartCat cfg, + srgStartCat = cfgStartCat cfg, srgExternalCats = cfgExternalCats cfg, srgLanguage = languageCode pgf cnc, - srgRules = mkRules cfg } + srgRules = mkRules cfg } where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc --- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), +-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), -- to C_N where N is an integer. renameCats :: String -> CFG -> CFG renameCats prefix cfg = mapCFGCats renameCat cfg where renameCat c | isExternal c = c ++ "_cat" | otherwise = Map.findWithDefault (badCat c) c names - isExternal c = c `Set.member` cfgExternalCats cfg + isExternal c = c `Set.member` cfgExternalCats cfg catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)] names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]] badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg) cfRulesToSRGRule :: [CFRule] -> SRGRule cfRulesToSRGRule rs@(r:_) = SRGRule (ruleLhs r) rhs - where + where alts = [((n,Nothing),mkSRGSymbols 0 ss) | Rule c ss n <- rs] rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ] @@ -153,7 +153,7 @@ srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats) -- non-optimizing version: --srgItem = unionRE . map seqRE --- | Merges a list of right-hand sides which all have the same +-- | Merges a list of right-hand sides which all have the same -- sequence of non-terminals. mergeItems :: [[SRGSymbol]] -> SRGItem mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens @@ -174,16 +174,16 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map prSRG :: Options -> SRG -> String prSRG opts srg = prProductions $ map prRule $ ext ++ int - where + where sisr = flag optSISR opts (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg) prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts))) - prAlt (SRGAlt _ t rhs) = - -- FIXME: hack: we high-jack the --sisr flag to add + prAlt (SRGAlt _ t rhs) = + -- FIXME: hack: we high-jack the --sisr flag to add -- a simple lambda calculus format for semantic interpretation -- Maybe the --sisr flag should be renamed. case sisr of - Just _ -> + Just _ -> -- copy tags to each part of a top-level union, -- to get simpler output case rhs of diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs index dc5c7bbd3..3db8fe7c2 100644 --- a/src/compiler/GF/Speech/SRGS_ABNF.hs +++ b/src/compiler/GF/Speech/SRGS_ABNF.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/01 20:09:04 $ +-- > CVS $Date: 2005/11/01 20:09:04 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.16 $ -- @@ -38,7 +38,7 @@ width :: Int width = 75 srgsAbnfPrinter :: Options - -> PGF -> CId -> String + -> PGF -> CId -> String srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc where sisr = flag optSISR opts @@ -72,7 +72,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc prItem sisr t = f 0 where f _ (REUnion []) = pp "$VOID" - f p (REUnion xs) + f p (REUnion xs) | not (null es) = brackets (f 0 (REUnion nes)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) where (es,nes) = partition isEpsilon xs @@ -84,13 +84,13 @@ prItem sisr t = f 0 prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) -prSymbol _ cn (Terminal t) +prSymbol _ cn (Terminal t) | all isPunct t = empty -- removes punctuation | otherwise = pp t -- FIXME: quote if there is whitespace or odd chars tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc tag Nothing _ = empty -tag (Just fmt) t = +tag (Just fmt) t = case t fmt of [] -> empty -- grr, silly SRGS ABNF does not have an escaping mechanism @@ -125,4 +125,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs ($++$) :: Doc -> Doc -> Doc x $++$ y = x $$ emptyLine $$ y - diff --git a/src/compiler/GF/Speech/SRGS_XML.hs b/src/compiler/GF/Speech/SRGS_XML.hs index 397bfb739..17d8eec5c 100644 --- a/src/compiler/GF/Speech/SRGS_XML.hs +++ b/src/compiler/GF/Speech/SRGS_XML.hs @@ -34,13 +34,13 @@ prSrgsXml :: Maybe SISRFormat -> SRG -> String prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr) where xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $ - [meta "description" + [meta "description" ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."), meta "generator" "Grammatical Framework"] - ++ map ruleToXML (srgRules srg) + ++ map ruleToXML (srgRules srg) ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts) where pub = if isExternalCat srg cat then [("scope","public")] else [] - prRhs rhss = [oneOf (map (mkProd sisr) rhss)] + prRhs rhss = [oneOf (map (mkProd sisr) rhss)] mkProd :: Maybe SISRFormat -> SRGAlt -> XML mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) @@ -50,9 +50,9 @@ mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML mkItem sisr cn = f - where + where f (REUnion []) = ETag "ruleref" [("special","VOID")] - f (REUnion xs) + f (REUnion xs) | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)] | otherwise = oneOf (map f xs) where (es,nes) = partition isEpsilon xs @@ -62,7 +62,7 @@ mkItem sisr cn = f f (RESymbol s) = symItem sisr cn s symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML -symItem sisr cn (NonTerminal n@(c,_)) = +symItem sisr cn (NonTerminal n@(c,_)) = Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n) symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)] @@ -81,12 +81,12 @@ oneOf = Tag "one-of" [] grammar :: Maybe SISRFormat -> String -- ^ root -> Maybe String -- ^language - -> [XML] -> XML -grammar sisr root ml = + -> [XML] -> XML +grammar sisr root ml = Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"), - ("version","1.0"), - ("mode","voice"), - ("root",root)] + ("version","1.0"), + ("mode","voice"), + ("root",root)] ++ (if isJust sisr then [("tag-format","semantics/1.0")] else []) ++ maybe [] (\l -> [("xml:lang", l)]) ml @@ -94,7 +94,7 @@ meta :: String -> String -> XML meta n c = ETag "meta" [("name",n),("content",c)] optimizeSRGS :: XML -> XML -optimizeSRGS = bottomUpXML f +optimizeSRGS = bottomUpXML f where f (Tag "item" [] [x@(Tag "item" _ _)]) = x f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs diff --git a/src/compiler/GF/Text/Transliterations.hs b/src/compiler/GF/Text/Transliterations.hs index 9b1b6e151..8dbc02823 100644 --- a/src/compiler/GF/Text/Transliterations.hs +++ b/src/compiler/GF/Text/Transliterations.hs @@ -17,7 +17,7 @@ import qualified Data.Map as Map -- to add a new one: define the Unicode range and the corresponding ASCII strings, -- which may be one or more characters long --- conventions to be followed: +-- conventions to be followed: -- each character is either [letter] or [letter+nonletters] -- when using a sparse range of unicodes, mark missing codes as "-" in transliterations -- characters can be invisible: ignored in translation to unicode @@ -33,7 +33,7 @@ transliterateWithFile name src isFrom = (if isFrom then appTransFromUnicode else appTransToUnicode) (getTransliterationFile name src) transliteration :: String -> Maybe Transliteration -transliteration s = Map.lookup s allTransliterations +transliteration s = Map.lookup s allTransliterations allTransliterations = Map.fromList [ ("amharic",transAmharic), @@ -67,25 +67,25 @@ data Transliteration = Trans { } appTransToUnicode :: Transliteration -> String -> String -appTransToUnicode trans = +appTransToUnicode trans = concat . map (\c -> maybe c (return . toEnum) $ Map.lookup c (trans_to_unicode trans) - ) . - filter (flip notElem (invisible_chars trans)) . + ) . + filter (flip notElem (invisible_chars trans)) . unchar appTransFromUnicode :: Transliteration -> String -> String -appTransFromUnicode trans = +appTransFromUnicode trans = concat . - map (\c -> maybe [toEnum c] id $ + map (\c -> maybe [toEnum c] id $ Map.lookup c (trans_from_unicode trans) - ) . + ) . map fromEnum mkTransliteration :: String -> [String] -> [Int] -> Transliteration -mkTransliteration name ts us = +mkTransliteration name ts us = Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name where tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"] @@ -102,7 +102,7 @@ getTransliterationFile name = uncurry (mkTransliteration name) . codes unchar :: String -> [String] unchar s = case s of - c:d:cs + c:d:cs | isAlpha d -> [c] : unchar (d:cs) | isSpace d -> [c]:[d]: unchar cs | otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in @@ -122,8 +122,8 @@ transThai = mkTransliteration "Thai" allTrans allCodes where allCodes = [0x0e00 .. 0x0e7f] transDevanagari :: Transliteration -transDevanagari = - (mkTransliteration "Devanagari" +transDevanagari = + (mkTransliteration "Devanagari" allTransUrduHindi allCodes){invisible_chars = ["a"]} where allCodes = [0x0900 .. 0x095f] ++ [0x0966 .. 0x096f] @@ -136,13 +136,13 @@ allTransUrduHindi = words $ "- - - - - - - - q x g. z R R' f - " ++ "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " - + transUrdu :: Transliteration -transUrdu = +transUrdu = (mkTransliteration "Urdu" allTrans allCodes) where - allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++ + allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++ [0x0654,0x0658,0x0679,0x067e,0x0686,0x0688,0x0691,0x0698,0x06af,0x06c1,0x06c3,0x06cc,0x06ba,0x06be,0x06d2] ++ - [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] + [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] allTrans = words $ "A - w^ - y^ a b - t C j H K d " ++ -- 0622 - 062f "Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a @@ -151,22 +151,22 @@ transUrdu = "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ." transSindhi :: Transliteration -transSindhi = +transSindhi = (mkTransliteration "Sindhi" allTrans allCodes) where allCodes = [0x062e] ++ [0x0627 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641 .. 0x0648] ++ [0x067a,0x067b,0x067d,0x067e,0x067f] ++ [0x0680 .. 0x068f] ++ [0x0699,0x0918,0x06a6,0x061d,0x06a9,0x06af,0x06b3,0x06bb,0x06be,0x06f6,0x064a,0x06b1, 0x06aa, 0x06fd, 0x06fe] ++ - [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] + [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] allTrans = words $ "K a b - t C j H - d " ++ -- 0626 - 062f "Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a "f q - L m n - W " ++ -- 0641 - 0648 "T! B T p T' " ++ -- 067a,067b,067d,067e,067f "B' - - Y' J' - c c' - - d! - d' D - D' " ++ -- 0680 - 068f - "R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1 + "R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1 "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ." - + transArabic :: Transliteration transArabic = mkTransliteration "Arabic" allTrans allCodes where @@ -175,8 +175,8 @@ transArabic = mkTransliteration "Arabic" allTrans allCodes where "W r z s C S D T Z c G " ++ -- 0630 - 063a " f q k l m n h w y. y a. u. i. a u " ++ -- 0641 - 064f "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 - "A* q?" -- 0671 (used by AED) - allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ + "A* q?" -- 0671 (used by AED) + allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f] @@ -193,16 +193,16 @@ transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes) " V A: A? w? A- y? A b t. t t- j H K d " ++ -- 0621 - 062f "W r z s C S D T Z c G " ++ -- 0630 - 063a " f q - l m n h v - y. a. u. i. a u " ++ -- 0640 - 064f - "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 + "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 "p c^ J k g y q? Z0" - allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ - [0x0641..0x064f] ++ [0x0650..0x0657] ++ + allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ + [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x067e,0x0686,0x0698,0x06a9,0x06af,0x06cc,0x061f,0x200c] transNepali :: Transliteration transNepali = mkTransliteration "Nepali" allTrans allCodes where allTrans = words $ - "z+ z= " ++ + "z+ z= " ++ "- V M h: - H A i: I: f F Z - - - e: " ++ "E: - - O W k K g G n: C c j J Y q " ++ "Q x X N t T d D n - p P b B m y " ++ @@ -241,7 +241,7 @@ transGreek = mkTransliteration "modern Greek" allTrans allCodes where "i= A B G D E Z H V I K L M N X O " ++ "P R - S T Y F C Q W I- Y- a' e' h' i' " ++ "y= a b g d e z h v i k l m n x o " ++ - "p r s* s t y f c q w i- y- o' y' w' - " + "p r s* s t y f c q w i- y- o' y' w' - " allCodes = [0x0380 .. 0x03cf] transAncientGreek :: Transliteration @@ -261,32 +261,32 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where "y) y( y)` y(` y)' y(' y)~ y(~ - Y( - Y(` - Y(' - Y(~ " ++ "w) w( w)` w(` w)' w(' w)~ w(~ W) W( W)` W(` W)' W(' W)~ W(~ " ++ "a` a' e` e' h` h' i` i' o` o' y` y' w` w' - - " ++ - "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80- - "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90- - "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0- + "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80- + "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90- + "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0- "a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0- "- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0- "i. i_ i=` i=' - - i~ i=~ - - - - - - - - " ++ -- 1fd0- - "y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0- + "y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0- "- - w|` w| w|' - w~ w|~ - - - - - - - - " ++ -- 1ff0- -- HL, Private Use Area Code Points (New Athena Unicode, Cardo, ALPHABETUM, Antioch) -- see: http://apagreekkeys.org/technicalDetails.html -- GreekKeys Support by Donald Mastronarde - "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af + "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af "e~ e)~ e(~ e_ e_' e_` e_) e_( e_)` e_(` e_)' e_(' E)~ E(~ E_ E. " ++ -- e1b0-e1bf "o~ o)~ o(~ o_ o_' o_` o_) o_( o_)` o_(` o_)' o_(' O)~ O(~ O_ O. " ++ -- e1c0-e1cf - "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff - "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f + "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff + "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f "e_)~ e_(~ - - - - - e_~ - - - - - - - - " ++ -- eb20-eb2f - "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f + "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f "i.' i.) i.)' i.( i.` i.)` - i.(' i.(` - - - - - - - " ++ -- eb40-eb4f "- - - - i_)` i_(` - i_)~ i_(~ - o_~ o_)~ o_(~ - - - " ++ -- eb50-eb5f "y_` " ++ -- eb6f "y_~ y_)` - - - y_(` - y_)~ y_(~ - y_' - - y_) y_( y_)' " ++ -- eb70-eb7f "y_(' y.' y.( y.` y.) y.)' - - y.)` y.(' y.(` - - - - - " -- eb80-eb8f - allCodes = -- [0x00B0 .. 0x00Bf] - [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] - ++ [0xe1a0 .. 0xe1af] + allCodes = -- [0x00B0 .. 0x00Bf] + [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] + ++ [0xe1a0 .. 0xe1af] ++ [0xe1b0 .. 0xe1bf] ++ [0xe1c0 .. 0xe1cf] ++ [0xeaf0 .. 0xeaff] @@ -297,36 +297,34 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where ++ [0xeb50 .. 0xeb5f] ++ [0xeb6f] ++ [0xeb70 .. 0xeb7f] ++ [0xeb80 .. 0xeb8f] - -transAmharic :: Transliteration + +transAmharic :: Transliteration transAmharic = mkTransliteration "Amharic" allTrans allCodes where - -allTrans = words $ - - " h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++ - " H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++ - " s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++ - " - - - - - - - - x. x- x' x( x) x x? x* "++ - " q. q- q' q( q) q q? q* - - - - - - - - "++ - " - - - - - - - - - - - - - - - - "++ - " b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++ - " t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++ - " X. X- X' X( X) X X? - - - - X* - - - - "++ - " n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++ - " a u i A E e o e* k. k- k' k( k) k k? - "++ - " - - - k* - - - - - - - - - - - - "++ - " - - - - - - - - w. w- w' w( w) w w? w* "++ - " - - - - - - - - z. z- z' z( z) z z? z* "++ - " Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++ - " d. d- d' d( d) d d? d* - - - - - - - - "++ - " j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++ - " - - - g* - - - - - - - - - - - - "++ - " T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++ - " P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++ - " - - - - - - - - f. f- f' f( f) f f? f*"++ - " p. p- p' p( p) p p? p*" -allCodes = [0x1200..0x1357] - + allTrans = words $ + " h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++ + " H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++ + " s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++ + " - - - - - - - - x. x- x' x( x) x x? x* "++ + " q. q- q' q( q) q q? q* - - - - - - - - "++ + " - - - - - - - - - - - - - - - - "++ + " b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++ + " t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++ + " X. X- X' X( X) X X? - - - - X* - - - - "++ + " n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++ + " a u i A E e o e* k. k- k' k( k) k k? - "++ + " - - - k* - - - - - - - - - - - - "++ + " - - - - - - - - w. w- w' w( w) w w? w* "++ + " - - - - - - - - z. z- z' z( z) z z? z* "++ + " Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++ + " d. d- d' d( d) d d? d* - - - - - - - - "++ + " j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++ + " - - - g* - - - - - - - - - - - - "++ + " T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++ + " P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++ + " - - - - - - - - f. f- f' f( f) f f? f*"++ + " p. p- p' p( p) p p? p*" + allCodes = [0x1200..0x1357] + -- by Prasad 31/5/2013 transSanskrit :: Transliteration transSanskrit = (mkTransliteration "Sanskrit" allTrans allCodes) {invisible_chars = ["a"]} where diff --git a/src/compiler/SimpleEditor/JSON.hs b/src/compiler/SimpleEditor/JSON.hs index 8f607dc84..06586c5eb 100644 --- a/src/compiler/SimpleEditor/JSON.hs +++ b/src/compiler/SimpleEditor/JSON.hs @@ -9,14 +9,24 @@ instance JSON Grammar where showJSON (Grammar name extends abstract concretes) = makeObj ["basename".=name, "extends".=extends, "abstract".=abstract, "concretes".=concretes] + readJSON = error "Grammar.readJSON intentionally not defined" instance JSON Abstract where showJSON (Abstract startcat cats funs) = makeObj ["startcat".=startcat, "cats".=cats, "funs".=funs] + readJSON = error "Abstract.readJSON intentionally not defined" -instance JSON Fun where showJSON (Fun name typ) = signature name typ -instance JSON Param where showJSON (Param name rhs) = definition name rhs -instance JSON Oper where showJSON (Oper name rhs) = definition name rhs +instance JSON Fun where + showJSON (Fun name typ) = signature name typ + readJSON = error "Fun.readJSON intentionally not defined" + +instance JSON Param where + showJSON (Param name rhs) = definition name rhs + readJSON = error "Param.readJSON intentionally not defined" + +instance JSON Oper where + showJSON (Oper name rhs) = definition name rhs + readJSON = error "Oper.readJSON intentionally not defined" signature name typ = makeObj ["name".=name,"type".=typ] definition name rhs = makeObj ["name".=name,"rhs".=rhs] @@ -26,12 +36,15 @@ instance JSON Concrete where makeObj ["langcode".=langcode, "opens".=opens, "params".=params, "opers".=opers, "lincats".=lincats, "lins".=lins] + readJSON = error "Concrete.readJSON intentionally not defined" instance JSON Lincat where showJSON (Lincat cat lintype) = makeObj ["cat".=cat, "type".=lintype] + readJSON = error "Lincat.readJSON intentionally not defined" instance JSON Lin where showJSON (Lin fun args lin) = makeObj ["fun".=fun, "args".=args, "lin".=lin] + readJSON = error "Lin.readJSON intentionally not defined" infix 1 .= name .= v = (name,showJSON v) diff --git a/src/compiler/SimpleEditor/Syntax.hs b/src/compiler/SimpleEditor/Syntax.hs index 4a5eb6da8..8280ed461 100644 --- a/src/compiler/SimpleEditor/Syntax.hs +++ b/src/compiler/SimpleEditor/Syntax.hs @@ -23,10 +23,10 @@ data Fun = Fun { fname:: FunId, ftype:: Type } data Concrete = Concrete { langcode:: Id, opens:: [ModId], - params:: [Param], - lincats:: [Lincat], - opers:: [Oper], - lins:: [Lin] } + params:: [Param], + lincats:: [Lincat], + opers:: [Oper], + lins:: [Lin] } deriving Show data Param = Param {pname:: Id, prhs:: String} deriving Show diff --git a/src/runtime/c/INSTALL b/src/runtime/c/INSTALL index 6bbaefdce..c45c18fa9 100644 --- a/src/runtime/c/INSTALL +++ b/src/runtime/c/INSTALL @@ -14,6 +14,9 @@ For Linux users You will need the packages: autoconf, automake, libtool, make +- On Ubuntu: $ apt-get install autotools-dev +- On Fedora: $ dnf install autoconf automake libtool + The compilation steps are: $ autoreconf -i @@ -28,7 +31,7 @@ For Mac OSX users The following is what I did to make it work on MacOSX 10.8: - Install XCode and XCode command line tools -- Install Homebrew: http://mxcl.github.com/homebrew/ +- Install Homebrew: https://brew.sh $ brew install automake autoconf libtool $ glibtoolize @@ -49,7 +52,7 @@ For Windows users After the installation, don't forget to fix the fstab file. See here: http://www.mingw.org/wiki/Getting_Started -- From the MSYS shell (c:/MinGW/msys/1.0/msys.bat) go to the directory +- From the MSYS shell (c:/MinGW/msys/1.0/msys.bat) go to the directory which contains the INSTALL file and do: $ autoreconf -i diff --git a/src/runtime/c/install.sh b/src/runtime/c/install.sh new file mode 100755 index 000000000..78483719d --- /dev/null +++ b/src/runtime/c/install.sh @@ -0,0 +1,3 @@ +bash setup.sh configure +bash setup.sh build +bash setup.sh install diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index 85e55ab40..35ee628d1 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -19,7 +19,7 @@ wildCId = "_" :: CId type Cat = CId -- ^ Name of syntactic category type Fun = CId -- ^ Name of function -data BindType = +data BindType = Explicit | Implicit deriving Show @@ -38,7 +38,7 @@ instance Show Expr where show = showExpr [] instance Eq Expr where - (Expr e1 e1_touch) == (Expr e2 e2_touch) = + (Expr e1 e1_touch) == (Expr e2 e2_touch) = unsafePerformIO $ do res <- pgf_expr_eq e1 e2 e1_touch >> e2_touch @@ -113,9 +113,9 @@ unApp (Expr expr touch) = appl <- pgf_expr_unapply expr pl if appl == nullPtr then return Nothing - else do + else do fun <- peekCString =<< (#peek PgfApplication, fun) appl - arity <- (#peek PgfApplication, n_args) appl :: IO CInt + arity <- (#peek PgfApplication, n_args) appl :: IO CInt c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args)) return $ Just (fun, [Expr c_arg touch | c_arg <- c_args]) @@ -140,7 +140,9 @@ unStr (Expr expr touch) = touch return (Just s) --- | Constructs an expression from an integer literal +-- | Constructs an expression from an integer literal. +-- Note that the C runtime does not support long integers, and you may run into overflow issues with large values. +-- See [here](https://github.com/GrammaticalFramework/gf-core/issues/109) for more details. mkInt :: Int -> Expr mkInt val = unsafePerformIO $ do @@ -267,7 +269,7 @@ foreign import ccall "wrapper" -- in the expression in order reverse to the order -- of binding. showExpr :: [CId] -> Expr -> String -showExpr scope e = +showExpr scope e = unsafePerformIO $ withGuPool $ \tmpPl -> do (sb,out) <- newOut tmpPl diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index 91e77c77b..1d5f61991 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -1,19 +1,21 @@ name: pgf2 version: 1.3.0 + +cabal-version: 1.22 +build-type: Simple +license: LGPL-3 +license-file: LICENSE +category: Natural Language Processing synopsis: Bindings to the C version of the PGF runtime description: GF, Grammatical Framework, is a programming language for multilingual grammar applications. GF grammars are compiled into Portable Grammar Format (PGF) which can be used with the PGF runtime, written in C. This package provides Haskell bindings to that runtime. -homepage: https://www.grammaticalframework.org -license: LGPL-3 -license-file: LICENSE +homepage: https://www.grammaticalframework.org/ +bug-reports: https://github.com/GrammaticalFramework/gf-core/issues author: Krasimir Angelov -maintainer: kr.angelov@gmail.com -category: Language -build-type: Simple extra-source-files: CHANGELOG.md, README.md -cabal-version: >=1.10 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 library exposed-modules: @@ -24,9 +26,9 @@ library PGF2.Expr, PGF2.Type build-depends: - base >=4.3 && <5, - containers, - pretty + base >= 4.9.1 && < 4.15, + containers >= 0.5.7 && < 0.7, + pretty >= 1.1.3 && < 1.2 default-language: Haskell2010 build-tools: hsc2hs extra-libraries: pgf gu diff --git a/src/runtime/haskell-bind/stack-ghc7.10.3.yaml b/src/runtime/haskell-bind/stack-ghc7.10.3.yaml new file mode 100644 index 000000000..c916b4bb0 --- /dev/null +++ b/src/runtime/haskell-bind/stack-ghc7.10.3.yaml @@ -0,0 +1,3 @@ +resolver: lts-6.35 # ghc 7.10.3 + +allow-newer: true diff --git a/src/runtime/haskell-bind/stack-ghc8.0.2.yaml b/src/runtime/haskell-bind/stack-ghc8.0.2.yaml new file mode 100644 index 000000000..af08206d9 --- /dev/null +++ b/src/runtime/haskell-bind/stack-ghc8.0.2.yaml @@ -0,0 +1 @@ +resolver: lts-9.21 # ghc 8.0.2 diff --git a/src/runtime/haskell-bind/stack-ghc8.10.4.yaml b/src/runtime/haskell-bind/stack-ghc8.10.4.yaml new file mode 100644 index 000000000..195e90993 --- /dev/null +++ b/src/runtime/haskell-bind/stack-ghc8.10.4.yaml @@ -0,0 +1 @@ +resolver: lts-18.0 # ghc 8.10.4 diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs index b69371f0e..a74428f20 100644 --- a/src/runtime/haskell/Data/Binary/Builder.hs +++ b/src/runtime/haskell/Data/Binary/Builder.hs @@ -68,7 +68,7 @@ import qualified Data.ByteString.Lazy as L import Data.ByteString.Base (inlinePerformIO) import qualified Data.ByteString.Base as S #else -import Data.ByteString.Internal (inlinePerformIO) +import Data.ByteString.Internal (accursedUnutterablePerformIO) import qualified Data.ByteString.Internal as S --import qualified Data.ByteString.Lazy.Internal as L #endif @@ -199,7 +199,7 @@ defaultSize = 32 * k - overhead -- | Sequence an IO operation on the buffer unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder -unsafeLiftIO f = Builder $ \ k buf -> inlinePerformIO $ do +unsafeLiftIO f = Builder $ \ k buf -> accursedUnutterablePerformIO $ do buf' <- f buf return (k buf') {-# INLINE unsafeLiftIO #-} diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs index 01561d7d9..54f17ae95 100644 --- a/src/runtime/haskell/Data/Binary/Get.hs +++ b/src/runtime/haskell/Data/Binary/Get.hs @@ -423,7 +423,7 @@ readN n f = fmap f $ getBytes n getPtr :: Storable a => Int -> Get a getPtr n = do (fp,o,_) <- readN n B.toForeignPtr - return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) + return . B.accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) {- INLINE getPtr -} ------------------------------------------------------------------------ diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index e0e50f4be..a78472ea9 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -28,7 +28,7 @@ instance Binary PGF where let v = (major,minor) if major==pgfMajorVersion && minor<=pgfMinorVersion then getPGF' - else if v==Old.version + else if v==Old.version then Old.getPGF' else fail $ "Unsupported PGF version "++show (major,minor) @@ -185,6 +185,7 @@ instance Binary Instr where put (PUSH_ACCUM (LFlt d)) = putWord8 78 >> put d put (POP_ACCUM ) = putWord8 80 put (ADD ) = putWord8 84 + get = fail "Missing implementation for ‘get’ in the instance declaration for ‘Binary Instr’" instance Binary Type where put (DTyp hypos cat exps) = put (hypos,cat,exps) diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 5db4ef439..c5cc44b4e 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -41,7 +41,7 @@ import Control.Applicative import Control.Monad --import Control.Monad.Identity import Control.Monad.State -import Control.Monad.Error +import Control.Monad.Except import Text.PrettyPrint ----------------------------------------------------- diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal index 76e12bd2c..41e67f6ae 100644 --- a/src/runtime/haskell/pgf.cabal +++ b/src/runtime/haskell/pgf.cabal @@ -1,28 +1,32 @@ name: pgf -version: 3.10 +version: 3.11.0-git -cabal-version: >= 1.20 +cabal-version: 1.22 build-type: Simple license: OtherLicense category: Natural Language Processing synopsis: Grammatical Framework description: A library for interpreting the Portable Grammar Format (PGF) -homepage: http://www.grammaticalframework.org/ +homepage: https://www.grammaticalframework.org/ bug-reports: https://github.com/GrammaticalFramework/gf-core/issues -maintainer: Thomas Hallgren -tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 -Library - default-language: Haskell2010 - build-depends: base >= 4.6 && <5, - array, - containers, - bytestring, - utf8-string, - random, - pretty, - mtl, - exceptions +library + default-language: Haskell2010 + build-depends: + array >= 0.5.1 && < 0.6, + base >= 4.9.1 && < 4.15, + bytestring >= 0.10.8 && < 0.11, + containers >= 0.5.7 && < 0.7, + ghc-prim >= 0.5.0 && < 0.7, + mtl >= 2.2.1 && < 2.3, + pretty >= 1.1.3 && < 1.2, + random >= 1.1 && < 1.3, + utf8-string >= 1.0.1.1 && < 1.1 + + if impl(ghc<8.0) + build-depends: + fail >= 4.9.0 && < 4.10 other-modules: -- not really part of GF but I have changed the original binary library @@ -37,7 +41,6 @@ Library --if impl(ghc>=7.8) -- ghc-options: +RTS -A20M -RTS ghc-prof-options: -fprof-auto - extensions: exposed-modules: PGF diff --git a/src/runtime/haskell/stack-ghc7.10.3.yaml b/src/runtime/haskell/stack-ghc7.10.3.yaml new file mode 100644 index 000000000..c916b4bb0 --- /dev/null +++ b/src/runtime/haskell/stack-ghc7.10.3.yaml @@ -0,0 +1,3 @@ +resolver: lts-6.35 # ghc 7.10.3 + +allow-newer: true diff --git a/src/runtime/haskell/stack-ghc8.0.2.yaml b/src/runtime/haskell/stack-ghc8.0.2.yaml new file mode 100644 index 000000000..af08206d9 --- /dev/null +++ b/src/runtime/haskell/stack-ghc8.0.2.yaml @@ -0,0 +1 @@ +resolver: lts-9.21 # ghc 8.0.2 diff --git a/src/runtime/haskell/stack-ghc8.10.4.yaml b/src/runtime/haskell/stack-ghc8.10.4.yaml new file mode 100644 index 000000000..195e90993 --- /dev/null +++ b/src/runtime/haskell/stack-ghc8.10.4.yaml @@ -0,0 +1 @@ +resolver: lts-18.0 # ghc 8.10.4 diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 3f5307571..260c2e278 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -1032,6 +1032,7 @@ instance JSON PGF.Trie where showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf -- showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts] + readJSON = error "PGF.Trie.readJSON intentionally not defined" instance JSON PGF.CId where readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage diff --git a/src/server/URLEncoding.hs b/src/server/URLEncoding.hs index 881ca21cd..1a8f579b2 100644 --- a/src/server/URLEncoding.hs +++ b/src/server/URLEncoding.hs @@ -6,9 +6,9 @@ import Data.Char (chr,digitToInt,isHexDigit) -- | Decode hexadecimal escapes urlDecodeUnicode :: String -> String urlDecodeUnicode [] = "" -urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s) +urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s) | all isHexDigit [x1,x2,x3,x4] = - chr ( digitToInt x1 `shiftL` 12 + chr ( digitToInt x1 `shiftL` 12 .|. digitToInt x2 `shiftL` 8 .|. digitToInt x3 `shiftL` 4 .|. digitToInt x4) : urlDecodeUnicode s @@ -45,8 +45,8 @@ fromhex2 d1 d2 = 16*digitToInt d1+digitToInt d2 -- Repeatedly extract (and transform) values until a predicate hold. Return the list of values. unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b] unfoldr f p x | p x = [] - | otherwise = y:unfoldr f p x' - where (y, x') = f x + | otherwise = y:unfoldr f p x' + where (y, x') = f x chopList :: ([a] -> (b, [a])) -> [a] -> [b] chopList f l = unfoldr f null l @@ -54,8 +54,8 @@ chopList f l = unfoldr f null l breakAt :: (Eq a) => a -> [a] -> ([a], [a]) breakAt _ [] = ([], []) breakAt x (x':xs) = - if x == x' then - ([], xs) - else - let (ys, zs) = breakAt x xs - in (x':ys, zs) + if x == x' then + ([], xs) + else + let (ys, zs) = breakAt x xs + in (x':ys, zs) diff --git a/src/server/transfer/Fold.hs b/src/server/transfer/Fold.hs index 61f0d4b34..165e762fb 100644 --- a/src/server/transfer/Fold.hs +++ b/src/server/transfer/Fold.hs @@ -13,14 +13,14 @@ fold t = case unApp t of Just (i,[x]) -> case M.lookup i foldable of - Just j -> appFold j x - _ -> mkApp i [fold x] + Just j -> appFold j x + _ -> mkApp i [fold x] Just (i,xs) -> mkApp i $ map fold xs _ -> t appFold :: CId -> Tree -> Tree -appFold j t = +appFold j t = case unApp t of Just (i,[t,ts]) | isPre i "Cons" -> mkApp j [fold t, appFold j ts] Just (i,[t,s]) | isPre i "Base" -> mkApp j [fold t, fold s] - where isPre i s = take 4 (show i) == s \ No newline at end of file + where isPre i s = take 4 (show i) == s diff --git a/stack-ghc7.10.3.yaml b/stack-ghc7.10.3.yaml index 0761b54af..08ed036f5 100644 --- a/stack-ghc7.10.3.yaml +++ b/stack-ghc7.10.3.yaml @@ -4,9 +4,16 @@ extra-deps: - happy-1.19.9 - alex-3.2.4 - transformers-compat-0.6.5 +- directory-1.2.3.0 +- process-1.2.3.0@sha256:ee08707f1c806ad4a628c5997d8eb6e66d2ae924283548277d85a66341d57322,1806 allow-newer: true flags: transformers-compat: - four: true \ No newline at end of file + four: true +# gf: +# c-runtime: true +# +# extra-lib-dirs: +# - /usr/local/lib diff --git a/stack-ghc8.0.2.yaml b/stack-ghc8.0.2.yaml index af08206d9..f98141b0b 100644 --- a/stack-ghc8.0.2.yaml +++ b/stack-ghc8.0.2.yaml @@ -1 +1,7 @@ resolver: lts-9.21 # ghc 8.0.2 + +# flags: +# gf: +# c-runtime: true +# extra-lib-dirs: +# - /usr/local/lib diff --git a/stack-ghc8.10.4.yaml b/stack-ghc8.10.4.yaml new file mode 100644 index 000000000..b10f66e4f --- /dev/null +++ b/stack-ghc8.10.4.yaml @@ -0,0 +1,14 @@ +resolver: lts-18.0 # ghc 8.10.4 + +extra-deps: +- network-2.6.3.6 +- httpd-shed-0.4.0.3 +- cgi-3001.5.0.0@sha256:3d1193a328d5f627a021a0ef3927c1ae41dd341e32dba612fed52d0e3a6df056,2990 +- json-0.10@sha256:d9fc6b07ce92b8894825a17d2cf14799856767eb30c8bf55962baa579207d799,3210 +- multipart-0.2.0@sha256:b8770e3ff6089be4dd089a8250894b31287cca671f3d258190a505f9351fa8a9,1084 + +# flags: +# gf: +# c-runtime: true +# extra-lib-dirs: +# - /usr/local/lib diff --git a/stack-ghc8.2.2.yaml b/stack-ghc8.2.2.yaml index c33c53b33..4fd9ce775 100644 --- a/stack-ghc8.2.2.yaml +++ b/stack-ghc8.2.2.yaml @@ -4,3 +4,9 @@ extra-deps: - cgi-3001.3.0.3 - httpd-shed-0.4.0.3 - exceptions-0.10.2 + +# flags: +# gf: +# c-runtime: true +# extra-lib-dirs: +# - /usr/local/lib diff --git a/stack-ghc8.4.4.yaml b/stack-ghc8.4.4.yaml index c1a68e2d5..c1f059090 100644 --- a/stack-ghc8.4.4.yaml +++ b/stack-ghc8.4.4.yaml @@ -2,3 +2,9 @@ resolver: lts-12.26 # ghc 8.4.4 extra-deps: - cgi-3001.3.0.3 + +# flags: +# gf: +# c-runtime: true +# extra-lib-dirs: +# - /usr/local/lib diff --git a/stack-ghc8.6.5.yaml b/stack-ghc8.6.5.yaml index 2e66c7bf6..1895acca0 100644 --- a/stack-ghc8.6.5.yaml +++ b/stack-ghc8.6.5.yaml @@ -4,3 +4,9 @@ extra-deps: - network-2.6.3.6 - httpd-shed-0.4.0.3 - cgi-3001.5.0.0 + +# flags: +# gf: +# c-runtime: true +# extra-lib-dirs: +# - /usr/local/lib diff --git a/stack-ghc8.8.4.yaml b/stack-ghc8.8.4.yaml index a62db170b..95c807937 100644 --- a/stack-ghc8.8.4.yaml +++ b/stack-ghc8.8.4.yaml @@ -7,3 +7,8 @@ extra-deps: - json-0.10@sha256:d9fc6b07ce92b8894825a17d2cf14799856767eb30c8bf55962baa579207d799,3210 - multipart-0.2.0@sha256:b8770e3ff6089be4dd089a8250894b31287cca671f3d258190a505f9351fa8a9,1084 +# flags: +# gf: +# c-runtime: true +# extra-lib-dirs: +# - /usr/local/lib diff --git a/stack.yaml b/stack.yaml index f5d21085c..3a79afdf0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,18 @@ -# This default stack file is a copy of stack-ghc8.6.5.yaml -# But committing a symlink is probably a bad idea, so it's a real copy +# This default stack file is a copy of stack-ghc8.10.4.yaml +# But committing a symlink can be problematic on Windows, so it's a real copy. +# See: https://github.com/GrammaticalFramework/gf-core/pull/106 -resolver: lts-14.27 # ghc 8.6.5 +resolver: lts-18.0 # ghc 8.10.4 extra-deps: - network-2.6.3.6 - httpd-shed-0.4.0.3 -- cgi-3001.5.0.0 \ No newline at end of file +- cgi-3001.5.0.0@sha256:3d1193a328d5f627a021a0ef3927c1ae41dd341e32dba612fed52d0e3a6df056,2990 +- json-0.10@sha256:d9fc6b07ce92b8894825a17d2cf14799856767eb30c8bf55962baa579207d799,3210 +- multipart-0.2.0@sha256:b8770e3ff6089be4dd089a8250894b31287cca671f3d258190a505f9351fa8a9,1084 + +# flags: +# gf: +# c-runtime: true +# extra-lib-dirs: +# - /usr/local/lib diff --git a/testsuite/canonical/.gitignore b/testsuite/canonical/.gitignore new file mode 100644 index 000000000..72988cf10 --- /dev/null +++ b/testsuite/canonical/.gitignore @@ -0,0 +1 @@ +canonical/ diff --git a/testsuite/canonical/gold/FoodsFin.gf b/testsuite/canonical/gold/FoodsFin.gf new file mode 100644 index 000000000..de63d2b36 --- /dev/null +++ b/testsuite/canonical/gold/FoodsFin.gf @@ -0,0 +1,102 @@ +concrete FoodsFin of Foods = { +param ParamX_Number = ParamX_Sg | ParamX_Pl; +param Prelude_Bool = Prelude_False | Prelude_True; +param ResFin_Agr = ResFin_Ag ParamX_Number ParamX_Person | ResFin_AgPol; +param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3; +param ResFin_Harmony = ResFin_Back | ResFin_Front; +param ResFin_NForm = + ResFin_NCase ParamX_Number ResFin_Case | ResFin_NComit | ResFin_NInstruct | + ResFin_NPossNom ParamX_Number | ResFin_NPossGen ParamX_Number | + ResFin_NPossTransl ParamX_Number | ResFin_NPossIllat ParamX_Number | + ResFin_NCompound; +param ResFin_Case = + ResFin_Nom | ResFin_Gen | ResFin_Part | ResFin_Transl | ResFin_Ess | + ResFin_Iness | ResFin_Elat | ResFin_Illat | ResFin_Adess | ResFin_Ablat | + ResFin_Allat | ResFin_Abess; +param ResFin_NPForm = ResFin_NPCase ResFin_Case | ResFin_NPAcc | ResFin_NPSep; +lincat Comment = {s : Str}; + Item = + {s : ResFin_NPForm => Str; a : ResFin_Agr; isNeg : Prelude_Bool; + isPron : Prelude_Bool}; + Kind = + {s : ResFin_NForm => Str; h : ResFin_Harmony; + postmod : ParamX_Number => Str}; + Quality = + {s : Prelude_Bool => ResFin_NForm => Str; hasPrefix : Prelude_Bool; + p : Str}; +lin Expensive = + {s = + table {Prelude_False => + table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis"; + ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin"; + ResFin_NCase ParamX_Sg ResFin_Part => "kallista"; + ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi"; + ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina"; + ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa"; + ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista"; + ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen"; + ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla"; + ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta"; + ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille"; + ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta"; + ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit"; + ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden"; + ResFin_NCase ParamX_Pl ResFin_Part => "kalliita"; + ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi"; + ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina"; + ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa"; + ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista"; + ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin"; + ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla"; + ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta"; + ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille"; + ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta"; + ResFin_NComit => "kalliine"; + ResFin_NInstruct => "kalliin"; + ResFin_NPossNom ParamX_Sg => "kallii"; + ResFin_NPossNom ParamX_Pl => "kallii"; + ResFin_NPossGen ParamX_Sg => "kallii"; + ResFin_NPossGen ParamX_Pl => "kalliide"; + ResFin_NPossTransl ParamX_Sg => "kalliikse"; + ResFin_NPossTransl ParamX_Pl => "kalliikse"; + ResFin_NPossIllat ParamX_Sg => "kalliisee"; + ResFin_NPossIllat ParamX_Pl => "kalliisii"; + ResFin_NCompound => "kallis"}; + Prelude_True => + table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis"; + ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin"; + ResFin_NCase ParamX_Sg ResFin_Part => "kallista"; + ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi"; + ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina"; + ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa"; + ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista"; + ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen"; + ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla"; + ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta"; + ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille"; + ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta"; + ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit"; + ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden"; + ResFin_NCase ParamX_Pl ResFin_Part => "kalliita"; + ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi"; + ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina"; + ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa"; + ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista"; + ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin"; + ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla"; + ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta"; + ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille"; + ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta"; + ResFin_NComit => "kalliine"; + ResFin_NInstruct => "kalliin"; + ResFin_NPossNom ParamX_Sg => "kallii"; + ResFin_NPossNom ParamX_Pl => "kallii"; + ResFin_NPossGen ParamX_Sg => "kallii"; + ResFin_NPossGen ParamX_Pl => "kalliide"; + ResFin_NPossTransl ParamX_Sg => "kalliikse"; + ResFin_NPossTransl ParamX_Pl => "kalliikse"; + ResFin_NPossIllat ParamX_Sg => "kalliisee"; + ResFin_NPossIllat ParamX_Pl => "kalliisii"; + ResFin_NCompound => "kallis"}}; + hasPrefix = Prelude_False; p = ""}; +} \ No newline at end of file diff --git a/testsuite/canonical/gold/PhrasebookBul.gf b/testsuite/canonical/gold/PhrasebookBul.gf new file mode 100644 index 000000000..eb10cc48c --- /dev/null +++ b/testsuite/canonical/gold/PhrasebookBul.gf @@ -0,0 +1,29 @@ +concrete PhrasebookBul of Phrasebook = { +param Prelude_Bool = Prelude_False | Prelude_True; +param ResBul_AGender = ResBul_AMasc ResBul_Animacy | ResBul_AFem | ResBul_ANeut; +param ResBul_Animacy = ResBul_Human | ResBul_NonHuman; +param ResBul_Case = ResBul_Acc | ResBul_Dat | ResBul_WithPrep | ResBul_CPrep; +param ResBul_NForm = + ResBul_NF ParamX_Number ResBul_Species | ResBul_NFSgDefNom | + ResBul_NFPlCount | ResBul_NFVocative; +param ParamX_Number = ParamX_Sg | ParamX_Pl; +param ResBul_Species = ResBul_Indef | ResBul_Def; +lincat PlaceKind = + {at : {s : Str; c : ResBul_Case}; isPl : Prelude_Bool; + name : {s : ResBul_NForm => Str; g : ResBul_AGender}; + to : {s : Str; c : ResBul_Case}}; + VerbPhrase = {s : Str}; +lin Airport = + {at = {s = "на"; c = ResBul_Acc}; isPl = Prelude_False; + name = + {s = + table {ResBul_NF ParamX_Sg ResBul_Indef => "летище"; + ResBul_NF ParamX_Sg ResBul_Def => "летището"; + ResBul_NF ParamX_Pl ResBul_Indef => "летища"; + ResBul_NF ParamX_Pl ResBul_Def => "летищата"; + ResBul_NFSgDefNom => "летището"; + ResBul_NFPlCount => "летища"; + ResBul_NFVocative => "летище"}; + g = ResBul_ANeut}; + to = {s = "до"; c = ResBul_CPrep}}; +} \ No newline at end of file diff --git a/testsuite/canonical/gold/PhrasebookGer.gf b/testsuite/canonical/gold/PhrasebookGer.gf new file mode 100644 index 000000000..912f3b7b1 --- /dev/null +++ b/testsuite/canonical/gold/PhrasebookGer.gf @@ -0,0 +1,251 @@ +concrete PhrasebookGer of Phrasebook = { +param Prelude_Bool = Prelude_False | Prelude_True; +param ResGer_Agr = ResGer_Ag ResGer_Gender ParamX_Number ParamX_Person; +param ParamX_Number = ParamX_Sg | ParamX_Pl; +param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3; +param ResGer_Gender = ResGer_Masc | ResGer_Fem | ResGer_Neutr; +param ResGer_Control = ResGer_SubjC | ResGer_ObjC | ResGer_NoC; +param ResGer_PCase = ResGer_NPC ResGer_Case | ResGer_NPP ResGer_CPrep; +param ResGer_CPrep = + ResGer_CAnDat | ResGer_CInAcc | ResGer_CInDat | ResGer_CZuDat | + ResGer_CVonDat; +param ResGer_Case = ResGer_Nom | ResGer_Acc | ResGer_Dat | ResGer_Gen; +param ResGer_VAux = ResGer_VHaben | ResGer_VSein; +param ResGer_VForm = + ResGer_VInf Prelude_Bool | ResGer_VFin Prelude_Bool ResGer_VFormFin | + ResGer_VImper ParamX_Number | ResGer_VPresPart ResGer_AForm | + ResGer_VPastPart ResGer_AForm; +param ResGer_AForm = ResGer_APred | ResGer_AMod ResGer_GenNum ResGer_Case; +param ResGer_GenNum = ResGer_GSg ResGer_Gender | ResGer_GPl; +param ResGer_VFormFin = + ResGer_VPresInd ParamX_Number ParamX_Person | + ResGer_VPresSubj ParamX_Number ParamX_Person; +param ResGer_VType = ResGer_VAct | ResGer_VRefl ResGer_Case; +lincat PlaceKind = {s : Str}; + VerbPhrase = + {s : + {s : ResGer_VForm => Str; aux : ResGer_VAux; particle : Str; + prefix : Str; vtype : ResGer_VType}; + a1 : Str; a2 : Str; adj : Str; ext : Str; + inf : {s : Str; ctrl : ResGer_Control; isAux : Prelude_Bool}; + infExt : Str; isAux : Prelude_Bool; + nn : + ResGer_Agr => + {p1 : Str; p2 : Str; p3 : Str; p4 : Str; p5 : Str; p6 : Str}; + subjc : + {s : Str; c : ResGer_PCase; isPrep : Prelude_Bool; s2 : Str}}; +lin VRead = + {s = + {s = + table {ResGer_VInf Prelude_False => "lesen"; + ResGer_VInf Prelude_True => "zu" ++ "lesen"; + ResGer_VFin Prelude_False + (ResGer_VPresInd ParamX_Sg ParamX_P1) => + "lese"; + ResGer_VFin Prelude_False + (ResGer_VPresInd ParamX_Sg ParamX_P2) => + "liest"; + ResGer_VFin Prelude_False + (ResGer_VPresInd ParamX_Sg ParamX_P3) => + "liest"; + ResGer_VFin Prelude_False + (ResGer_VPresInd ParamX_Pl ParamX_P1) => + "lesen"; + ResGer_VFin Prelude_False + (ResGer_VPresInd ParamX_Pl ParamX_P2) => + "lest"; + ResGer_VFin Prelude_False + (ResGer_VPresInd ParamX_Pl ParamX_P3) => + "lesen"; + ResGer_VFin Prelude_False + (ResGer_VPresSubj ParamX_Sg ParamX_P1) => + "lese"; + ResGer_VFin Prelude_False + (ResGer_VPresSubj ParamX_Sg ParamX_P2) => + "lesest"; + ResGer_VFin Prelude_False + (ResGer_VPresSubj ParamX_Sg ParamX_P3) => + "lese"; + ResGer_VFin Prelude_False + (ResGer_VPresSubj ParamX_Pl ParamX_P1) => + "lesen"; + ResGer_VFin Prelude_False + (ResGer_VPresSubj ParamX_Pl ParamX_P2) => + "leset"; + ResGer_VFin Prelude_False + (ResGer_VPresSubj ParamX_Pl ParamX_P3) => + "lesen"; + ResGer_VFin Prelude_True + (ResGer_VPresInd ParamX_Sg ParamX_P1) => + "lese"; + ResGer_VFin Prelude_True + (ResGer_VPresInd ParamX_Sg ParamX_P2) => + "liest"; + ResGer_VFin Prelude_True + (ResGer_VPresInd ParamX_Sg ParamX_P3) => + "liest"; + ResGer_VFin Prelude_True + (ResGer_VPresInd ParamX_Pl ParamX_P1) => + "lesen"; + ResGer_VFin Prelude_True + (ResGer_VPresInd ParamX_Pl ParamX_P2) => + "lest"; + ResGer_VFin Prelude_True + (ResGer_VPresInd ParamX_Pl ParamX_P3) => + "lesen"; + ResGer_VFin Prelude_True + (ResGer_VPresSubj ParamX_Sg ParamX_P1) => + "lese"; + ResGer_VFin Prelude_True + (ResGer_VPresSubj ParamX_Sg ParamX_P2) => + "lesest"; + ResGer_VFin Prelude_True + (ResGer_VPresSubj ParamX_Sg ParamX_P3) => + "lese"; + ResGer_VFin Prelude_True + (ResGer_VPresSubj ParamX_Pl ParamX_P1) => + "lesen"; + ResGer_VFin Prelude_True + (ResGer_VPresSubj ParamX_Pl ParamX_P2) => + "leset"; + ResGer_VFin Prelude_True + (ResGer_VPresSubj ParamX_Pl ParamX_P3) => + "lesen"; + ResGer_VImper ParamX_Sg => "les"; + ResGer_VImper ParamX_Pl => "lest"; + ResGer_VPresPart ResGer_APred => "lesend"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Nom) => + "lesender"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Acc) => + "lesenden"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Dat) => + "lesendem"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Gen) => + "lesenden"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Nom) => + "lesende"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Acc) => + "lesende"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Dat) => + "lesender"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Gen) => + "lesender"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Nom) => + "lesendes"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Acc) => + "lesendes"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Dat) => + "lesendem"; + ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Gen) => + "lesenden"; + ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Nom) => + "lesende"; + ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Acc) => + "lesende"; + ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Dat) => + "lesenden"; + ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Gen) => + "lesender"; + ResGer_VPastPart ResGer_APred => "gelesen"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Nom) => + "gelesener"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Acc) => + "gelesenen"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Dat) => + "gelesenem"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc) + ResGer_Gen) => + "gelesenen"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Nom) => + "gelesene"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Acc) => + "gelesene"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Dat) => + "gelesener"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem) + ResGer_Gen) => + "gelesener"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Nom) => + "gelesenes"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Acc) => + "gelesenes"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Dat) => + "gelesenem"; + ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr) + ResGer_Gen) => + "gelesenen"; + ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Nom) => + "gelesene"; + ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Acc) => + "gelesene"; + ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Dat) => + "gelesenen"; + ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Gen) => + "gelesener"}; + aux = ResGer_VHaben; particle = ""; prefix = ""; + vtype = ResGer_VAct}; + a1 = ""; a2 = ""; adj = ""; ext = ""; + inf = {s = ""; ctrl = ResGer_NoC; isAux = Prelude_True}; infExt = ""; + isAux = Prelude_False; + nn = + table {ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P1 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P2 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P3 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P1 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P2 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P3 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P1 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P2 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P3 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P1 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P2 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P3 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P1 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P2 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P3 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P1 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P2 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}; + ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P3 => + {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}}; + subjc = + {s = ""; c = ResGer_NPC ResGer_Nom; isPrep = Prelude_False; + s2 = ""}}; +} \ No newline at end of file diff --git a/testsuite/canonical/grammars/Foods.gf b/testsuite/canonical/grammars/Foods.gf new file mode 100644 index 000000000..aa68d4429 --- /dev/null +++ b/testsuite/canonical/grammars/Foods.gf @@ -0,0 +1,16 @@ +-- (c) 2009 Aarne Ranta under LGPL + +abstract Foods = { + flags startcat = Comment ; + cat + Comment ; Item ; Kind ; Quality ; + fun + -- Pred : Item -> Quality -> Comment ; + -- This, That, These, Those : Kind -> Item ; + -- Mod : Quality -> Kind -> Kind ; + -- Wine, Cheese, Fish, Pizza : Kind ; + -- Very : Quality -> Quality ; + -- Fresh, Warm, Italian, + -- Expensive, Delicious, Boring : Quality ; + Expensive: Quality; +} diff --git a/testsuite/canonical/grammars/FoodsFin.gf b/testsuite/canonical/grammars/FoodsFin.gf new file mode 100644 index 000000000..962199805 --- /dev/null +++ b/testsuite/canonical/grammars/FoodsFin.gf @@ -0,0 +1,6 @@ + +-- (c) 2009 Aarne Ranta under LGPL + +concrete FoodsFin of Foods = FoodsI with + (Syntax = SyntaxFin), + (LexFoods = LexFoodsFin) ; diff --git a/testsuite/canonical/grammars/FoodsI.gf b/testsuite/canonical/grammars/FoodsI.gf new file mode 100644 index 000000000..f4113b724 --- /dev/null +++ b/testsuite/canonical/grammars/FoodsI.gf @@ -0,0 +1,29 @@ +-- (c) 2009 Aarne Ranta under LGPL + +incomplete concrete FoodsI of Foods = + open Syntax, LexFoods in { + lincat + Comment = Utt ; + Item = NP ; + Kind = CN ; + Quality = AP ; + lin + Pred item quality = mkUtt (mkCl item quality) ; + This kind = mkNP this_Det kind ; + That kind = mkNP that_Det kind ; + These kind = mkNP these_Det kind ; + Those kind = mkNP those_Det kind ; + Mod quality kind = mkCN quality kind ; + Very quality = mkAP very_AdA quality ; + + Wine = mkCN wine_N ; + Pizza = mkCN pizza_N ; + Cheese = mkCN cheese_N ; + Fish = mkCN fish_N ; + Fresh = mkAP fresh_A ; + Warm = mkAP warm_A ; + Italian = mkAP italian_A ; + Expensive = mkAP expensive_A ; + Delicious = mkAP delicious_A ; + Boring = mkAP boring_A ; +} diff --git a/testsuite/canonical/grammars/LexFoods.gf b/testsuite/canonical/grammars/LexFoods.gf new file mode 100644 index 000000000..12ace208c --- /dev/null +++ b/testsuite/canonical/grammars/LexFoods.gf @@ -0,0 +1,15 @@ +-- (c) 2009 Aarne Ranta under LGPL + +interface LexFoods = open Syntax in { + oper + wine_N : N ; + pizza_N : N ; + cheese_N : N ; + fish_N : N ; + fresh_A : A ; + warm_A : A ; + italian_A : A ; + expensive_A : A ; + delicious_A : A ; + boring_A : A ; +} diff --git a/testsuite/canonical/grammars/LexFoodsFin.gf b/testsuite/canonical/grammars/LexFoodsFin.gf new file mode 100644 index 000000000..8b12f449f --- /dev/null +++ b/testsuite/canonical/grammars/LexFoodsFin.gf @@ -0,0 +1,21 @@ +-- (c) 2009 Aarne Ranta under LGPL +--# -coding=latin1 + +instance LexFoodsFin of LexFoods = + open SyntaxFin, ParadigmsFin in { + oper + wine_N = mkN "viini" ; + pizza_N = mkN "pizza" ; + cheese_N = mkN "juusto" ; + fish_N = mkN "kala" ; + fresh_A = mkA "tuore" ; + warm_A = mkA + (mkN "l�mmin" "l�mpim�n" "l�mmint�" "l�mpim�n�" "l�mpim��n" + "l�mpimin�" "l�mpimi�" "l�mpimien" "l�mpimiss�" "l�mpimiin" + ) + "l�mpim�mpi" "l�mpimin" ; + italian_A = mkA "italialainen" ; + expensive_A = mkA "kallis" ; + delicious_A = mkA "herkullinen" ; + boring_A = mkA "tyls�" ; +} diff --git a/testsuite/canonical/grammars/Phrasebook.gf b/testsuite/canonical/grammars/Phrasebook.gf new file mode 100644 index 000000000..eff538f62 --- /dev/null +++ b/testsuite/canonical/grammars/Phrasebook.gf @@ -0,0 +1,9 @@ +abstract Phrasebook = { + +cat PlaceKind ; +fun Airport : PlaceKind ; + +cat VerbPhrase ; +fun VRead : VerbPhrase ; + +} diff --git a/testsuite/canonical/grammars/PhrasebookBul.gf b/testsuite/canonical/grammars/PhrasebookBul.gf new file mode 100644 index 000000000..347d69297 --- /dev/null +++ b/testsuite/canonical/grammars/PhrasebookBul.gf @@ -0,0 +1,31 @@ +--# -path=.:present + +concrete PhrasebookBul of Phrasebook = + open + SyntaxBul, + (R = ResBul), + ParadigmsBul, + Prelude in { + + lincat + PlaceKind = CNPlace ; + + oper + CNPlace : Type = {name : CN ; at : Prep ; to : Prep; isPl : Bool} ; + + mkPlace : N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \n,p -> + mkCNPlace (mkCN n) p to_Prep ; + + mkCNPlace : CN -> Prep -> Prep -> CNPlace = \p,i,t -> { + name = p ; + at = i ; + to = t ; + isPl = False + } ; + + na_Prep = mkPrep "на" R.Acc ; + + lin + Airport = mkPlace (mkN066 "летище") na_Prep ; + +} diff --git a/testsuite/canonical/grammars/PhrasebookGer.gf b/testsuite/canonical/grammars/PhrasebookGer.gf new file mode 100644 index 000000000..c6402297c --- /dev/null +++ b/testsuite/canonical/grammars/PhrasebookGer.gf @@ -0,0 +1,14 @@ +--# -path=.:present + +concrete PhrasebookGer of Phrasebook = + open + SyntaxGer, + LexiconGer in { + + lincat + VerbPhrase = VP ; + + lin + VRead = mkVP ; + +} diff --git a/testsuite/canonical/run-on-grammar.sh b/testsuite/canonical/run-on-grammar.sh new file mode 100755 index 000000000..f621035e3 --- /dev/null +++ b/testsuite/canonical/run-on-grammar.sh @@ -0,0 +1,36 @@ +#!/usr/bin/env sh + +# For a given grammar, compile into canonical format, +# then ensure that the canonical format itself is compilable. + +if [ $# -lt 1 ]; then + echo "Please specify concrete modules to test with, e.g.:" + echo "./run-on-grammar.sh ../../../gf-contrib/foods/FoodsEng.gf ../../../gf-contrib/foods/FoodsFin.gf" + exit 2 +fi + +FAILURES=0 + +for CNC_PATH in "$@"; do + CNC_FILE=$(basename "$CNC_PATH") + stack run -- --batch --output-format=canonical_gf "$CNC_PATH" + if [ $? -ne 0 ]; then + echo "Failed to compile into canonical" + FAILURES=$((FAILURES+1)) + continue + fi + + stack run -- --batch "canonical/$CNC_FILE" + if [ $? -ne 0 ]; then + echo "Failed to compile canonical" + FAILURES=$((FAILURES+1)) + fi +done + +# Summary +if [ $FAILURES -ne 0 ]; then + echo "Failures: $FAILURES" + exit 1 +else + echo "All tests passed" +fi diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh new file mode 100755 index 000000000..81c03c5d1 --- /dev/null +++ b/testsuite/canonical/run.sh @@ -0,0 +1,54 @@ +#!/usr/bin/env sh + +FAILURES=0 + +# https://github.com/GrammaticalFramework/gf-core/issues/100 +stack run -- --batch --output-format=canonical_gf grammars/PhrasebookBul.gf +stack run -- --batch canonical/PhrasebookBul.gf +if [ $? -ne 0 ]; then + echo "Canonical grammar doesn't compile: FAIL" + FAILURES=$((FAILURES+1)) +else + # echo "Canonical grammar compiles: OK" + diff canonical/PhrasebookBul.gf gold/PhrasebookBul.gf + if [ $? -ne 0 ]; then + echo "Canonical grammar doesn't match gold version: FAIL" + FAILURES=$((FAILURES+1)) + else + echo "Canonical grammar matches gold version: OK" + fi +fi + +echo "" + +# https://github.com/GrammaticalFramework/gf-core/issues/101 +stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf +diff canonical/PhrasebookGer.gf gold/PhrasebookGer.gf +if [ $? -ne 0 ]; then + echo "Canonical grammar doesn't match gold version: FAIL" + FAILURES=$((FAILURES+1)) +else + echo "Canonical grammar matches gold version: OK" +fi + +echo "" + +# https://github.com/GrammaticalFramework/gf-core/issues/102 +stack run -- --batch --output-format=canonical_gf grammars/FoodsFin.gf +diff canonical/FoodsFin.gf gold/FoodsFin.gf +if [ $? -ne 0 ]; then + echo "Canonical grammar doesn't match gold version: FAIL" + FAILURES=$((FAILURES+1)) +else + echo "Canonical grammar matches gold version: OK" +fi + +echo "" + +# Summary +if [ $FAILURES -ne 0 ]; then + echo "Failures: $FAILURES" + exit 1 +else + echo "All tests passed" +fi diff --git a/testsuite/compiler/check/cyclic/abs-types/test3.gfs.gold b/testsuite/compiler/check/cyclic/abs-types/test3.gfs.gold new file mode 100644 index 000000000..e69de29bb diff --git a/testsuite/compiler/check/lincat-types/Predef.gf b/testsuite/compiler/check/lincat-types/Predef.gf new file mode 100644 index 000000000..fded5ae38 --- /dev/null +++ b/testsuite/compiler/check/lincat-types/Predef.gf @@ -0,0 +1,48 @@ +--1 Predefined functions for concrete syntax + +-- The definitions of these constants are hard-coded in GF, and defined +-- in Predef.hs (gf-core/src/compiler/GF/Compile/Compute/Predef.hs). +-- Applying them to run-time variables leads to compiler errors that are +-- often only detected at the code generation time. + +resource Predef = { + +-- This type of booleans is for internal use only. + + param PBool = PTrue | PFalse ; + + oper Error : Type = variants {} ; -- the empty type + oper Float : Type = variants {} ; -- the type of floats + oper Int : Type = variants {} ; -- the type of integers + oper Ints : Int -> PType = variants {} ; -- the type of integers from 0 to n + + oper error : Str -> Error = variants {} ; -- forms error message + oper length : Tok -> Int = variants {} ; -- length of string + oper drop : Int -> Tok -> Tok = variants {} ; -- drop prefix of length + oper take : Int -> Tok -> Tok = variants {} ; -- take prefix of length + oper tk : Int -> Tok -> Tok = variants {} ; -- drop suffix of length + oper dp : Int -> Tok -> Tok = variants {} ; -- take suffix of length + oper eqInt : Int -> Int -> PBool = variants {} ; -- test if equal integers + oper lessInt: Int -> Int -> PBool = variants {} ; -- test order of integers + oper plus : Int -> Int -> Int = variants {} ; -- add integers + oper eqStr : Tok -> Tok -> PBool = variants {} ; -- test if equal strings + oper occur : Tok -> Tok -> PBool = variants {} ; -- test if occurs as substring + oper occurs : Tok -> Tok -> PBool = variants {} ; -- test if any char occurs + oper isUpper : Tok -> PBool = variants {} ; -- test if all chars are upper-case + oper toUpper : Tok -> Tok = variants {} ; -- map all chars to upper case + oper toLower : Tok -> Tok = variants {} ; -- map all chars to lower case + oper show : (P : Type) -> P -> Tok = variants {} ; -- convert param to string + oper read : (P : Type) -> Tok -> P = variants {} ; -- convert string to param + oper eqVal : (P : Type) -> P -> P -> PBool = variants {} ; -- test if equal values + oper toStr : (L : Type) -> L -> Str = variants {} ; -- find the "first" string + oper mapStr : (L : Type) -> (Str -> Str) -> L -> L = variants {} ; + -- map all strings in a data structure; experimental --- + + oper nonExist : Str = variants {} ; -- a placeholder for non-existant morphological forms + oper BIND : Str = variants {} ; -- a token for gluing + oper SOFT_BIND : Str = variants {} ; -- a token for soft gluing + oper SOFT_SPACE : Str = variants {} ; -- a token for soft space + oper CAPIT : Str = variants {} ; -- a token for capitalization + oper ALL_CAPIT : Str = variants {} ; -- a token for capitalization of abreviations + +} ; diff --git a/testsuite/compiler/check/lincat-types/test.gfs.gold b/testsuite/compiler/check/lincat-types/test.gfs.gold index 7e95ec7af..2e14e89e6 100644 --- a/testsuite/compiler/check/lincat-types/test.gfs.gold +++ b/testsuite/compiler/check/lincat-types/test.gfs.gold @@ -1,7 +1,9 @@ -testsuite/compiler/check/lincat-types/TestCnc.gf:3: - Happened in linearization type of S - type of PTrue - expected: Type - inferred: PBool +testsuite/compiler/check/lincat-types/TestCnc.gf: + testsuite/compiler/check/lincat-types/TestCnc.gf:3: + Happened in linearization type of S + type of PTrue + expected: Type + inferred: Predef.PBool + diff --git a/testsuite/compiler/check/lins/lins.gfs.gold b/testsuite/compiler/check/lins/lins.gfs.gold index 149912bde..798c91e43 100644 --- a/testsuite/compiler/check/lins/lins.gfs.gold +++ b/testsuite/compiler/check/lins/lins.gfs.gold @@ -1,39 +1,41 @@ -checking module linsCnc - Warning: no linearization type for C, inserting default {s : Str} - Warning: no linearization of test -abstract lins { - cat C Nat ; - cat Float ; - cat Int ; - cat Nat ; - cat String ; - fun test : C zero ; - fun zero : Nat ; -} -concrete linsCnc { - productions - C1 -> F2[] - lindefs - C0 -> F0 - C1 -> F1 - lin - F0 := (S0) [lindef C] - F1 := () [lindef Nat] - F2 := () [zero] - sequences - S0 := {0,0} - categories - C := range [C0 .. C0] - labels ["s"] - Float := range [CFloat .. CFloat] - labels ["s"] - Int := range [CInt .. CInt] - labels ["s"] - Nat := range [C1 .. C1] - labels [] - String := range [CString .. CString] - labels ["s"] - __gfVar := range [CVar .. CVar] - labels [""] - printnames -} +abstract lins { + cat C Nat ; + cat Float ; + cat Int ; + cat Nat ; + cat String ; + fun test : C zero ; + fun zero : Nat ; +} +concrete linsCnc { + productions + C1 -> F4[] + lindefs + C0 -> F0[CVar] + C1 -> F2[CVar] + linrefs + CVar -> F1[C0] + CVar -> F3[C1] + lin + F0 := (S2) ['lindef C'] + F1 := (S1) ['lindef C'] + F2 := () ['lindef Nat'] + F3 := (S0) ['lindef Nat'] + F4 := () [zero] + sequences + S0 := + S1 := <0,0> + S2 := {0,0} + categories + C := range [C0 .. C0] + labels ["s"] + Float := range [CFloat .. CFloat] + labels ["s"] + Int := range [CInt .. CInt] + labels ["s"] + Nat := range [C1 .. C1] + labels [] + String := range [CString .. CString] + labels ["s"] + printnames +} diff --git a/testsuite/compiler/check/oper-definition/test.gfs.gold b/testsuite/compiler/check/oper-definition/test.gfs.gold index 240819c74..373ef17bd 100644 --- a/testsuite/compiler/check/oper-definition/test.gfs.gold +++ b/testsuite/compiler/check/oper-definition/test.gfs.gold @@ -1,5 +1,6 @@ -testsuite/compiler/check/oper-definition/Res.gf:3: - Happened in operation my_oper - No definition given to the operation +testsuite/compiler/check/oper-definition/Res.gf: + testsuite/compiler/check/oper-definition/Res.gf:3: + Happened in operation my_oper + No definition given to the operation diff --git a/testsuite/compiler/check/strMatch/Prelude.gf b/testsuite/compiler/check/strMatch/Prelude.gf new file mode 100644 index 000000000..1c5b50354 --- /dev/null +++ b/testsuite/compiler/check/strMatch/Prelude.gf @@ -0,0 +1,161 @@ +--1 The GF Prelude + +-- This file defines some prelude facilities usable in all grammars. + +resource Prelude = Predef[nonExist, BIND, SOFT_BIND, SOFT_SPACE, CAPIT, ALL_CAPIT] ** open (Predef=Predef) in { + +oper + +--2 Strings, records, and tables + + SS : Type = {s : Str} ; + ss : Str -> SS = \s -> {s = s} ; + ss2 : (_,_ : Str) -> SS = \x,y -> ss (x ++ y) ; + ss3 : (_,_ ,_: Str) -> SS = \x,y,z -> ss (x ++ y ++ z) ; + + cc2 : (_,_ : SS) -> SS = \x,y -> ss (x.s ++ y.s) ; + cc3 : (_,_,_ : SS) -> SS = \x,y,z -> ss (x.s ++ y.s ++ z.s) ; + + SS1 : PType -> Type = \P -> {s : P => Str} ; + ss1 : (A : PType) -> Str -> SS1 A = \A,s -> {s = table {_ => s}} ; + + SP1 : Type -> Type = \P -> {s : Str ; p : P} ; + sp1 : (A : Type) -> Str -> A -> SP1 A = \_,s,a -> {s = s ; p = a} ; + + constTable : (A : PType) -> (B : Type) -> B -> A => B = \u,v,b -> \\_ => b ; + constStr : (A : PType) -> Str -> A => Str = \A -> constTable A Str ; + +-- Discontinuous constituents. + + SD2 : Type = {s1,s2 : Str} ; + sd2 : (_,_ : Str) -> SD2 = \x,y -> {s1 = x ; s2 = y} ; + + +--2 Optional elements + +-- Optional string with preference on the string vs. empty. + + optStr : Str -> Str = \s -> variants {s ; []} ; + strOpt : Str -> Str = \s -> variants {[] ; s} ; + +-- Free order between two strings. + + bothWays : Str -> Str -> Str = \x,y -> variants {x ++ y ; y ++ x} ; + +-- Parametric order between two strings. + + preOrPost : Bool -> Str -> Str -> Str = \pr,x,y -> + if_then_Str pr (x ++ y) (y ++ x) ; + +--2 Infixes. prefixes, and postfixes + +-- Fixes with precedences are defined in [Precedence Precedence.html]. + + infixSS : Str -> SS -> SS -> SS = \f,x,y -> ss (x.s ++ f ++ y.s) ; + prefixSS : Str -> SS -> SS = \f,x -> ss (f ++ x.s) ; + postfixSS : Str -> SS -> SS = \f,x -> ss (x.s ++ f) ; + embedSS : Str -> Str -> SS -> SS = \f,g,x -> ss (f ++ x.s ++ g) ; + + +--2 Booleans + + param Bool = False | True ; + +oper + if_then_else : (A : Type) -> Bool -> A -> A -> A = \_,c,d,e -> + case c of { + True => d ; ---- should not need to qualify + False => e + } ; + + andB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a b False ; + orB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a True b ; + notB : Bool -> Bool = \a -> if_then_else Bool a False True ; + + if_then_Str : Bool -> Str -> Str -> Str = if_then_else Str ; + + onlyIf : Bool -> Str -> Str = \b,s -> case b of { + True => s ; + _ => nonExist + } ; + +-- Interface to internal booleans + + pbool2bool : Predef.PBool -> Bool = \b -> case b of { + Predef.PFalse => False ; Predef.PTrue => True + } ; + + init : Tok -> Tok = Predef.tk 1 ; + last : Tok -> Tok = Predef.dp 1 ; + +--2 High-level acces to Predef operations + + isNil : Tok -> Bool = \b -> pbool2bool (Predef.eqStr [] b) ; + + ifTok : (A : Type) -> Tok -> Tok -> A -> A -> A = \A,t,u,a,b -> + case Predef.eqStr t u of {Predef.PTrue => a ; Predef.PFalse => b} ; + +--2 Lexer-related operations + +-- Bind together two tokens in some lexers, either obligatorily or optionally + + oper + glue : Str -> Str -> Str = \x,y -> x ++ BIND ++ y ; + glueOpt : Str -> Str -> Str = \x,y -> variants {glue x y ; x ++ y} ; + noglueOpt : Str -> Str -> Str = \x,y -> variants {x ++ y ; glue x y} ; + +-- Force capitalization of next word in some unlexers + + capitalize : Str -> Str = \s -> CAPIT ++ s ; + +-- These should be hidden, and never changed since they are hardcoded in (un)lexers + + PARA : Str = "&-" ; + +-- Embed between commas, where the latter one disappears in front of other punctuation + + embedInCommas : Str -> Str = \s -> bindComma ++ s ++ endComma ; + endComma : Str = pre {"," | "." => []; "" => bindComma ; _ => []} ; + + bindComma : Str = SOFT_BIND ++ "," ; + optComma : Str = bindComma | [] ; + optCommaSS : SS -> SS = \s -> ss (s.s ++ optComma) ; + +--2 Miscellaneous + +-- Identity function + + id : (A : Type) -> A -> A = \_,a -> a ; + +-- Parentheses + + paren : Str -> Str = \s -> "(" ++ s ++ ")" ; + parenss : SS -> SS = \s -> ss (paren s.s) ; + +-- Zero, one, two, or more (elements in a list etc) + +param + ENumber = E0 | E1 | E2 | Emore ; + +oper + eNext : ENumber -> ENumber = \e -> case e of { + E0 => E1 ; E1 => E2 ; _ => Emore} ; + +-- convert initial to upper/lower + + toUpperFirst : Str -> Str = \s -> case s of { + x@? + xs => Predef.toUpper x + xs ; + _ => s + } ; + + toLowerFirst : Str -> Str = \s -> case s of { + x@? + xs => Predef.toLower x + xs ; + _ => s + } ; + +-- handling errors caused by temporarily missing definitions + + notYet : Str -> Predef.Error = \s -> + Predef.error ("NOT YET IMPLEMENTED:" ++ s) ; + +} diff --git a/testsuite/compiler/check/strMatch/strMatch.gfs.gold b/testsuite/compiler/check/strMatch/strMatch.gfs.gold new file mode 100644 index 000000000..8b1378917 --- /dev/null +++ b/testsuite/compiler/check/strMatch/strMatch.gfs.gold @@ -0,0 +1 @@ + diff --git a/testsuite/compiler/params/params.gfs.gold b/testsuite/compiler/params/params.gfs.gold new file mode 100644 index 000000000..e69de29bb diff --git a/testsuite/compiler/typecheck/abstract/LetInDefAbs.gfs.gold b/testsuite/compiler/typecheck/abstract/LetInDefAbs.gfs.gold new file mode 100644 index 000000000..e4613af56 --- /dev/null +++ b/testsuite/compiler/typecheck/abstract/LetInDefAbs.gfs.gold @@ -0,0 +1,15 @@ +fun f : Int -> Int ; +def f n = ? ; +000 CHECK_ARGS 1 + ALLOC 2 + PUT_CLOSURE 001 + SET_PAD + TUCK hp(0) 1 + EVAL f tail(0) +001 ALLOC 2 + PUT_LIT 0 + PUSH_FRAME + PUSH hp(0) + EVAL f update +Probability: 1.0 + diff --git a/testsuite/compiler/typecheck/abstract/LetInTypesAbs.gfs.gold b/testsuite/compiler/typecheck/abstract/LetInTypesAbs.gfs.gold index 588b1643d..bbd381681 100644 --- a/testsuite/compiler/typecheck/abstract/LetInTypesAbs.gfs.gold +++ b/testsuite/compiler/typecheck/abstract/LetInTypesAbs.gfs.gold @@ -1 +1,3 @@ -fun f : (Int -> Int) -> Int -> Int +fun f : (Int -> Int) -> Int -> Int ; +Probability: 1.0 + diff --git a/testsuite/compiler/typecheck/abstract/LitAbs.gf b/testsuite/compiler/typecheck/abstract/LitAbs.gf index 03f850232..08230b8cf 100644 --- a/testsuite/compiler/typecheck/abstract/LitAbs.gf +++ b/testsuite/compiler/typecheck/abstract/LitAbs.gf @@ -5,7 +5,7 @@ cat CStr String ; CFloat Float ; data empty : CStr "" ; - null : CStr [] ; + -- null : CStr [] ; -- Commented out by IL 06/2021: causes parse error other : CStr "other" ; data zero : CInt 0 ; diff --git a/testsuite/compiler/typecheck/abstract/LitAbs.gfs b/testsuite/compiler/typecheck/abstract/LitAbs.gfs index ce10daa20..71c4cca29 100644 --- a/testsuite/compiler/typecheck/abstract/LitAbs.gfs +++ b/testsuite/compiler/typecheck/abstract/LitAbs.gfs @@ -1,5 +1,4 @@ i -src testsuite/compiler/typecheck/abstract/LitAbs.gf -ai null ai empty ai other ai zero diff --git a/testsuite/compiler/typecheck/abstract/LitAbs.gfs.gold b/testsuite/compiler/typecheck/abstract/LitAbs.gfs.gold index 83dda9094..2d1e93979 100644 --- a/testsuite/compiler/typecheck/abstract/LitAbs.gfs.gold +++ b/testsuite/compiler/typecheck/abstract/LitAbs.gfs.gold @@ -1,5 +1,12 @@ -data null : CStr "" -data empty : CStr "" -data other : CStr "other" -data zero : CInt 0 -data pi : CFloat 3.14 +data empty : CStr "" ; +Probability: 0.5 + +data other : CStr "other" ; +Probability: 0.5 + +data zero : CInt 0 ; +Probability: 1.0 + +data pi : CFloat 3.14 ; +Probability: 1.0 + diff --git a/testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs b/testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs index 0b07b7ed4..1edc94e02 100644 --- a/testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs +++ b/testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs @@ -1,2 +1,5 @@ i -src testsuite/compiler/typecheck/abstract/PolyTypes.gf -i -src testsuite/compiler/typecheck/abstract/RecTypes.gf \ No newline at end of file +ai f + +i -src testsuite/compiler/typecheck/abstract/RecTypes.gf +ai f \ No newline at end of file diff --git a/testsuite/compiler/typecheck/abstract/test_A.gfs.gold b/testsuite/compiler/typecheck/abstract/test_A.gfs.gold index 821a4da2c..d99a5ec08 100644 --- a/testsuite/compiler/typecheck/abstract/test_A.gfs.gold +++ b/testsuite/compiler/typecheck/abstract/test_A.gfs.gold @@ -1,5 +1,6 @@ -testsuite/compiler/typecheck/abstract/A.gf:4: - Happened in the category B - Prod expected for function A instead of Type +testsuite/compiler/typecheck/abstract/A.gf: + testsuite/compiler/typecheck/abstract/A.gf:4: + Happened in the category B + Prod expected for function A instead of Type diff --git a/testsuite/compiler/typecheck/abstract/test_B.gfs.gold b/testsuite/compiler/typecheck/abstract/test_B.gfs.gold index 1355ff7c5..3c923c6de 100644 --- a/testsuite/compiler/typecheck/abstract/test_B.gfs.gold +++ b/testsuite/compiler/typecheck/abstract/test_B.gfs.gold @@ -1,5 +1,6 @@ -testsuite/compiler/typecheck/abstract/B.gf:5: - Happened in the type of function f - Prod expected for function S instead of Type +testsuite/compiler/typecheck/abstract/B.gf: + testsuite/compiler/typecheck/abstract/B.gf:5: + Happened in the type of function f + Prod expected for function S instead of Type diff --git a/testsuite/compiler/typecheck/abstract/test_C.gfs.gold b/testsuite/compiler/typecheck/abstract/test_C.gfs.gold index d055b11cd..d86aeda8b 100644 --- a/testsuite/compiler/typecheck/abstract/test_C.gfs.gold +++ b/testsuite/compiler/typecheck/abstract/test_C.gfs.gold @@ -1,5 +1,6 @@ -testsuite/compiler/typecheck/abstract/C.gf:6: - Happened in the definition of function f - {Int <> S} +testsuite/compiler/typecheck/abstract/C.gf: + testsuite/compiler/typecheck/abstract/C.gf:6: + Happened in the definition of function f + {Int <> S} diff --git a/testsuite/compiler/typecheck/concrete/test_A.gfs.gold b/testsuite/compiler/typecheck/concrete/test_A.gfs.gold index 1bd4dffab..19b66a865 100644 --- a/testsuite/compiler/typecheck/concrete/test_A.gfs.gold +++ b/testsuite/compiler/typecheck/concrete/test_A.gfs.gold @@ -1,5 +1,9 @@ -testsuite/compiler/typecheck/concrete/A.gf:5: - Happened in operation silly - A function type is expected for a_Det instead of type Str +testsuite/compiler/typecheck/concrete/A.gf: + testsuite/compiler/typecheck/concrete/A.gf:5: + Happened in operation silly + A function type is expected for a_Det instead of type Str + + ** Maybe you gave too many arguments to a_Det + diff --git a/testsuite/libraries/exx-resource.gfs b/testsuite/libraries/exx-resource.gfs deleted file mode 100644 index 31163a1bd..000000000 --- a/testsuite/libraries/exx-resource.gfs +++ /dev/null @@ -1,226 +0,0 @@ -se utf8 -i alltenses/LangEng.gfo -i alltenses/LangSwe.gfo -i alltenses/LangBul.gfo --- Adjective - -l -treebank PositA warm_A -l -treebank ComparA warm_A (UsePron i_Pron) -l -treebank ComplA2 married_A2 (UsePron she_Pron) -l -treebank ComplA2 married_A2 (DetNP (DetQuant (PossPron she_Pron) NumPl)) -l -treebank ComplA2 married_A2 (DetNP (DetQuant (PossPron she_Pron) NumSg)) -l -treebank ReflA2 married_A2 -l -treebank PositA (UseA2 married_A2) -l -treebank SentAP (PositA good_A) (EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseComp (CompAdv here_Adv))))) -l -treebank AdAP very_AdA (PositA warm_A) - - --- Adverb - -l -treebank PositAdvAdj warm_A -l -treebank PrepNP in_Prep (DetCN (DetQuant DefArt NumSg) (UseN house_N)) -l -treebank ComparAdvAdj more_CAdv warm_A (UsePN john_PN) -l -treebank ComparAdvAdjS more_CAdv warm_A (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV run_V))) -l -treebank SubjS when_Subj (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V))) -l -treebank AdNum (AdnCAdv more_CAdv) (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))) - - --- Conjunction - -l -treebank ConjS and_Conj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV walk_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V)))) -l -treebank ConjAP and_Conj (BaseAP (PositA cold_A) (PositA warm_A)) -l -treebank ConjNP or_Conj (BaseNP (UsePron she_Pron) (UsePron we_Pron)) -l -treebank ConjAdv or_Conj (BaseAdv here_Adv there_Adv) -l -treebank ConjS either7or_DConj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV walk_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V)))) -l -treebank ConjAP both7and_DConj (BaseAP (PositA warm_A) (PositA cold_A)) -l -treebank ConjNP either7or_DConj (BaseNP (UsePron he_Pron) (UsePron she_Pron)) -l -treebank ConjAdv both7and_DConj (BaseAdv here_Adv there_Adv) - --- Idiom - -l -treebank ImpersCl (UseComp (CompAP (PositA hot_A))) -l -treebank GenericCl (UseV sleep_V) -l -treebank CleftNP (UsePron i_Pron) (UseRCl (TTAnt TPast ASimul) PPos (RelVP IdRP (ComplSlash (SlashV2a do_V2) (UsePron it_Pron)))) -l -treebank CleftAdv here_Adv (UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V))) -l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (UseN house_N)) -l -treebank ExistIP (IdetCN (IdetQuant which_IQuant NumPl) (UseN house_N)) -l -treebank PredVP (UsePron i_Pron) (ProgrVP (UseV sleep_V)) -l -treebank ImpPl1 (UseV go_V) - --- Noun - -l -treebank DetCN (DetQuant DefArt NumSg) (UseN man_N) -l -treebank UsePN john_PN -l -treebank UsePron he_Pron -l -treebank PredetNP only_Predet (DetCN (DetQuant DefArt NumSg) (UseN man_N)) -l -treebank PPartNP (DetCN (DetQuant DefArt NumSg) (UseN man_N)) see_V2 -l -treebank AdvNP (UsePN paris_PN) today_Adv -l -treebank RelNP (UsePN paris_PN) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (UseComp (CompAdv here_Adv)))) -l -treebank DetNP (DetQuant this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) -l -treebank DetCN (DetQuantOrd this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))) (OrdSuperl good_A)) (UseN man_N) -l -treebank DetCN (DetQuant this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN man_N) -l -treebank DetCN (DetQuant this_Quant NumPl) (UseN man_N) -l -treebank DetCN (DetQuant this_Quant NumSg) (UseN man_N) -l -treebank NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))) -l -treebank NumCard (NumDigits (IIDig D_5 (IDig D_1))) -l -treebank NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot1plus n5 pot01))))) -l -treebank NumCard (AdNum almost_AdN (NumDigits (IIDig D_5 (IDig D_1)))) -l -treebank OrdDigits (IIDig D_5 (IDig D_1)) -l -treebank OrdNumeral (num (pot2as3 (pot1as2 (pot1plus n5 pot01)))) -l -treebank OrdSuperl warm_A -l -treebank DetCN (DetQuantOrd DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))) (OrdSuperl good_A)) (UseN man_N) -l -treebank DetCN (DetQuant DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN man_N) -l -treebank DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 pot01))))))) (UseN man_N) -l -treebank DetCN (DetQuant DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 pot01))))))) (UseN man_N) -l -treebank DetCN (DetQuant DefArt NumSg) (UseN man_N) -l -treebank DetCN (DetQuant DefArt NumPl) (UseN man_N) -l -treebank MassNP (UseN beer_N) -l -treebank DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN house_N) -l -treebank UseN house_N -l -treebank ComplN2 mother_N2 (DetCN (DetQuant DefArt NumSg) (UseN king_N)) -l -treebank ComplN2 (ComplN3 distance_N3 (DetCN (DetQuant this_Quant NumSg) (UseN city_N))) (UsePN paris_PN) -l -treebank UseN2 mother_N2 -l -treebank ComplN2 (Use2N3 distance_N3) (DetCN (DetQuant this_Quant NumSg) (UseN city_N)) -l -treebank ComplN2 (Use3N3 distance_N3) (UsePN paris_PN) -l -treebank UseN2 (Use2N3 distance_N3) -l -treebank AdjCN (PositA big_A) (UseN house_N) -l -treebank RelCN (UseN house_N) (UseRCl (TTAnt TPast ASimul) PPos (RelSlash IdRP (SlashVP (UsePN john_PN) (SlashV2a buy_V2)))) -l -treebank AdvCN (UseN house_N) (PrepNP on_Prep (DetCN (DetQuant DefArt NumSg) (UseN hill_N))) -l -treebank SentCN (UseN question_N) (EmbedQS (UseQCl (TTAnt TPres ASimul) PPos (QuestIAdv where_IAdv (PredVP (UsePron she_Pron) (UseV sleep_V))))) -l -treebank DetCN (DetQuant DefArt NumSg) (ApposCN (UseN city_N) (UsePN paris_PN)) -l -treebank DetCN (DetQuant (PossPron i_Pron) NumSg) (ApposCN (UseN friend_N) (UsePN john_PN)) - --- Numeral - -l -treebank num (pot2as3 (pot1as2 (pot0as1 (pot0 n6)))) -l -treebank num (pot2as3 (pot1as2 (pot0as1 pot01))) -l -treebank num (pot2as3 (pot1as2 (pot1 n6))) -l -treebank num (pot2as3 (pot1as2 pot110)) -l -treebank num (pot2as3 (pot1as2 pot111)) -l -treebank num (pot2as3 (pot1as2 (pot1to19 n6))) -l -treebank num (pot2as3 (pot1as2 (pot1 n6))) -l -treebank num (pot2as3 (pot1as2 (pot1plus n6 (pot0 n5)))) -l -treebank num (pot2as3 (pot2 (pot0 n4))) -l -treebank num (pot2as3 (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7)))) -l -treebank num (pot3 (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7)))) -l -treebank num (pot3plus (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7))) (pot1as2 (pot1plus n8 (pot0 n9)))) -l -treebank IDig D_8 -l -treebank IIDig D_8 (IIDig D_0 (IIDig D_0 (IIDig D_1 (IIDig D_7 (IIDig D_8 (IDig D_9)))))) - - --- Phrase - -l -treebank PhrUtt but_PConj (UttImpSg PPos (ImpVP (AdvVP (UseV come_V) here_Adv))) (VocNP (DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN friend_N))) -l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePN john_PN) (UseV walk_V)))) NoVoc -l -treebank UttQS (UseQCl (TTAnt TPres ASimul) PPos (QuestCl (PredVP (UsePron it_Pron) (UseComp (CompAP (PositA good_A)))))) -l -treebank UttImpSg PNeg (ImpVP (ReflVP (SlashV2a love_V2))) -l -treebank UttImpPl PNeg (ImpVP (ReflVP (SlashV2a love_V2))) -l -treebank UttImpPol PNeg (ImpVP (UseV sleep_V)) -l -treebank UttIP whoPl_IP -l -treebank UttIP whoSg_IP -l -treebank UttIAdv why_IAdv -l -treebank UttNP (DetCN (DetQuant this_Quant NumSg) (UseN man_N)) -l -treebank UttAdv here_Adv -l -treebank UttVP (UseV sleep_V) -l -treebank VocNP (DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN friend_N)) - - --- Question - -l -treebank QuestCl (PredVP (UsePN john_PN) (UseV walk_V)) -l -treebank QuestVP whoSg_IP (UseV walk_V) -l -treebank QuestSlash whoSg_IP (SlashVP (UsePN john_PN) (SlashV2a love_V2)) -l -treebank QuestIAdv why_IAdv (PredVP (UsePN john_PN) (UseV walk_V)) -l -treebank QuestIComp (CompIAdv where_IAdv) (UsePN john_PN) -l -treebank IdetCN (IdetQuant which_IQuant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN song_N) -l -treebank IdetIP (IdetQuant which_IQuant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) -l -treebank AdvIP whoSg_IP (PrepNP in_Prep (UsePN paris_PN)) -l -treebank IdetIP (IdetQuant which_IQuant NumSg) -l -treebank PrepIP with_Prep whoSg_IP -l -treebank QuestIComp (CompIAdv where_IAdv) (UsePron it_Pron) -l -treebank QuestIComp (CompIP whoSg_IP) (UsePron it_Pron) - - --- Relative - -l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelCl (PredVP (UsePN john_PN) (ComplSlash (SlashV2a love_V2) (UsePron she_Pron))))))) -l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (ComplSlash (SlashV2a love_V2) (UsePN john_PN)))))) -l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePN john_PN) (SlashV2a love_V2)))))) -l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash (FunRP possess_Prep (DetCN (DetQuant DefArt NumSg) (UseN2 mother_N2)) IdRP) (SlashVP (UsePN john_PN) (SlashV2a love_V2)))))) - --- Sentence - -l -treebank PredVP (UsePN john_PN) (UseV walk_V) -l -treebank PredSCVP (EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV go_V)))) (UseComp (CompAP (PositA good_A))) -l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron he_Pron) (SlashV2a see_V2)))) -l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (AdvSlash (SlashVP (UsePron he_Pron) (SlashV2a see_V2)) today_Adv))) -l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashPrep (PredVP (UsePron he_Pron) (UseV walk_V)) with_Prep))) -l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVS (UsePron she_Pron) say_VS (UseSlash (TTAnt TPres ASimul) PPos (SlashVP (UsePron he_Pron) (SlashV2a love_V2)))))) -l -treebank ImpVP (ReflVP (SlashV2a love_V2)) -l -treebank EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV go_V))) -l -treebank EmbedQS (UseQCl (TTAnt TPres ASimul) PPos (QuestVP whoSg_IP (UseV go_V))) -l -treebank EmbedVP (UseV go_V) -l -treebank UseCl (TTAnt TCond AAnter) PNeg (PredVP (UsePN john_PN) (UseV walk_V)) -l -treebank UseQCl (TTAnt TCond AAnter) PNeg (QuestCl (PredVP (UsePN john_PN) (UseV walk_V))) -l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TCond AAnter) PNeg (RelVP IdRP (UseV walk_V))) -l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TCond AAnter) PNeg (RelSlash IdRP (SlashPrep (PredVP (UsePron i_Pron) (UseV walk_V)) with_Prep))) -l -treebank RelS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V))) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (UseComp (CompAP (PositA good_A))))) - - --- Text - -l -treebank TEmpty -l -treebank TFullStop (PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePN john_PN) (UseV walk_V)))) NoVoc) TEmpty -l -treebank TQuestMark (PhrUtt NoPConj (UttQS (UseQCl (TTAnt TPres ASimul) PPos (QuestCl (PredVP (UsePron they_Pron) (UseComp (CompAdv here_Adv)))))) NoVoc) TEmpty -l -treebank TExclMark (PhrUtt NoPConj (ImpPl1 (UseV go_V)) NoVoc) TEmpty - --- Verb - -l -treebank PredVP (UsePron i_Pron) (UseV sleep_V) -l -treebank PredVP (UsePron i_Pron) (ComplVV want_VV (UseV run_V)) -l -treebank PredVP (UsePron i_Pron) (ComplVS say_VS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V)))) -l -treebank PredVP (UsePron i_Pron) (ComplVQ wonder_VQ (UseQCl (TTAnt TPres ASimul) PPos (QuestVP whoSg_IP (UseV run_V)))) -l -treebank PredVP (UsePron they_Pron) (ComplVA become_VA (PositA red_A)) -l -treebank PredVP (UsePron i_Pron) (ComplSlash (Slash3V3 give_V3 (UsePron he_Pron)) (UsePron it_Pron)) -l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2V beg_V2V (UseV go_V)) (UsePron she_Pron)) -l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2S answer_V2S (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron it_Pron) (UseComp (CompAP (PositA good_A)))))) (UsePron he_Pron)) -l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2Q ask_V2Q (UseQCl (TTAnt TPast ASimul) PPos (QuestVP whoSg_IP (UseV come_V)))) (UsePron he_Pron)) -l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2A paint_V2A (PositA red_A)) (UsePron it_Pron)) -l -treebank RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron i_Pron) (SlashVV want_VV (SlashV2a buy_V2))))) -l -treebank RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron they_Pron) (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashV2a buy_V2))))) -l -treebank PredVP (UsePron he_Pron) (ReflVP (SlashV2a love_V2)) -l -treebank PredVP (DetNP (DetQuant this_Quant NumSg)) (UseComp (CompAP (PositA warm_A))) -l -treebank PredVP (UsePron we_Pron) (PassV2 love_V2) -l -treebank PredVP (UsePron we_Pron) (AdvVP (UseV sleep_V) here_Adv) -l -treebank PredVP (UsePron we_Pron) (AdVVP always_AdV (UseV sleep_V)) -l -treebank PredVP (UsePron we_Pron) (UseComp (CompAP (PositA small_A))) -l -treebank PredVP (UsePron i_Pron) (UseComp (CompNP (DetCN (DetQuant IndefArt NumSg) (UseN man_N)))) -l -treebank PredVP (UsePron i_Pron) (UseComp (CompAdv here_Adv)) - - - --- Janna's and Krasimir's long examples - -l -treebank RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron they_Pron) (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashVV want_VV (SlashV2A paint_V2A (PositA red_A))))))) -l -treebank PhrUtt NoPConj (UttImpSg PPos (ImpVP (AdVVP always_AdV (ComplSlash (SlashV2a listen_V2) (DetCN (DetQuant DefArt NumSg) (UseN sea_N)))))) NoVoc -l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (ExistNP (PredetNP only_Predet (DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n2)))))))) (AdvCN (RelCN (UseN woman_N) (UseRCl (TTAnt TCond ASimul) PPos (RelSlash IdRP (SlashPrep (PredVP (UsePron i_Pron) (ComplVV want_VV (PassV2 see_V2))) with_Prep)))) (PrepNP in_Prep (DetCN (DetQuant DefArt NumSg) (UseN rain_N))))))))) NoVoc -l -treebank PhrUtt NoPConj (UttImpSg PPos (ImpVP (ComplSlash (SlashV2A paint_V2A (ConjAP both7and_DConj (BaseAP (ComparA small_A (DetCN (DetQuant DefArt NumSg) (UseN sun_N))) (ComparA big_A (DetCN (DetQuant DefArt NumSg) (UseN moon_N)))))) (DetCN (DetQuant DefArt NumSg) (UseN earth_N))))) NoVoc -l -treebank PhrUtt NoPConj (ImpPl1 (ComplVS hope_VS (ConjS either7or_DConj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumSg) (ComplN2 father_N2 (DetCN (DetQuant DefArt NumSg) (UseN baby_N)))) (UseV run_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumSg) (UseN2 (Use2N3 distance_N3))) (UseComp (CompAP (PositA small_A))))))))) NoVoc -l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN every_Det (UseN baby_N)) (UseComp (CompNP (ConjNP either7or_DConj (BaseNP (DetCN (DetQuant IndefArt NumSg) (UseN boy_N)) (DetCN (DetQuant IndefArt NumSg) (UseN girl_N))))))))) NoVoc -l -treebank PhrUtt NoPConj (UttAdv (ConjAdv either7or_DConj (ConsAdv here7from_Adv (BaseAdv there_Adv everywhere_Adv)))) NoVoc -l -treebank PhrUtt NoPConj (UttVP (PassV2 know_V2)) NoVoc -l -treebank RelCN (UseN bird_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron i_Pron) (SlashVV want_VV (SlashV2A paint_V2A (PositA red_A)))))) -l -treebank UttImpSg PPos (ImpVP (ComplVV want_VV (ComplSlash (SlashV2a buy_V2) (UsePron it_Pron)))) -l -treebank UttImpSg PPos (ImpVP (ComplVV want_VV (ComplSlash (SlashV2A paint_V2A (PositA red_A)) (UsePron it_Pron)))) -l -treebank UttImpSg PPos (ImpVP (ComplSlash (SlashVV want_VV (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashV2a buy_V2))) (UsePron it_Pron))) -l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumPl) (UseN fruit_N)) (ReflVP (Slash3V3 sell_V3 (DetCN (DetQuant DefArt NumSg) (UseN road_N))))))) NoVoc -l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2V beg_V2V (UseV live_V)))))) NoVoc -l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2S answer_V2S (UseCl (TTAnt TPres ASimul) PPos (ImpersCl (ComplVV must_VV (ReflVP (SlashV2a understand_V2)))))))))) NoVoc -l -treebank PhrUtt NoPConj (UttImpSg PPos (ImpVP (ReflVP (SlashV2Q ask_V2Q (UseQCl (TTAnt TPast ASimul) PPos (QuestVP whoSg_IP (UseV come_V))))))) NoVoc -l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2A paint_V2A (ComparA beautiful_A (UsePN john_PN))))))) NoVoc - --- more long examples - -l -treebank UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant this_Quant NumSg) (UseN grammar_N)) (ComplSlash (SlashV2a speak_V2) (DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot1to19 n2))))))) (UseN language_N))))) -l -treebank UseCl (TTAnt TPast AAnter) PPos (PredVP (UsePron she_Pron) (ComplSlash (SlashV2a buy_V2) (DetCN (DetQuant IndefArt NumSg) (AdjCN (PositA red_A) (UseN house_N))))) - diff --git a/testsuite/libraries/exx-resource.gfs.gold b/testsuite/libraries/exx-resource.gfs.gold deleted file mode 100644 index b9cec44d5..000000000 --- a/testsuite/libraries/exx-resource.gfs.gold +++ /dev/null @@ -1,1032 +0,0 @@ -Lang: PositA warm_A -LangEng: warm -LangSwe: varm -LangBul: топъл - - -Lang: ComparA warm_A (UsePron i_Pron) -LangEng: warmer than I -LangSwe: varmare än jag -LangBul: по - топъл от мен - - -Lang: ComplA2 married_A2 (UsePron she_Pron) -LangEng: married to her -LangSwe: gift med henne -LangBul: женен за нея - - -Lang: ComplA2 married_A2 (DetNP (DetQuant (PossPron she_Pron) NumPl)) -LangEng: married to hers -LangSwe: gift med hennes -LangBul: женен за нейните - - -Lang: ComplA2 married_A2 (DetNP (DetQuant (PossPron she_Pron) NumSg)) -LangEng: married to hers -LangSwe: gift med hennes -LangBul: женен за нейното - - -Lang: ReflA2 married_A2 -LangEng: married to myself -LangSwe: gift med sig -LangBul: женен за себе си - - -Lang: PositA (UseA2 married_A2) -LangEng: married -LangSwe: gift -LangBul: женен - - -Lang: SentAP (PositA good_A) (EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseComp (CompAdv here_Adv))))) -LangEng: good that she is here -LangSwe: god att hon är här -LangBul: добър , че тя е тук - - -Lang: AdAP very_AdA (PositA warm_A) -LangEng: very warm -LangSwe: mycket varm -LangBul: много топъл - - -Lang: PositAdvAdj warm_A -LangEng: warmly -LangSwe: varmt -LangBul: топло - - -Lang: PrepNP in_Prep (DetCN (DetQuant DefArt NumSg) (UseN house_N)) -LangEng: in the house -LangSwe: i huset -LangBul: в къщата - - -Lang: ComparAdvAdj more_CAdv warm_A (UsePN john_PN) -LangEng: more warmly than John -LangSwe: mer varmt än Johan -LangBul: по - топло от Джон - - -Lang: ComparAdvAdjS more_CAdv warm_A (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV run_V))) -LangEng: more warmly than he runs -LangSwe: mer varmt än han springer -LangBul: по - топло от колкото той бяга - - -Lang: SubjS when_Subj (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V))) -LangEng: when she sleeps -LangSwe: när hon sover -LangBul: когато тя спи - - -Lang: AdNum (AdnCAdv more_CAdv) (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))) -LangEng: more than five -LangSwe: mer än fem -LangBul: повече от пет - - -Lang: ConjS and_Conj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV walk_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V)))) -LangEng: he walks and she runs -LangSwe: han går och hon springer -LangBul: той ходи и тя бяга - - -Lang: ConjAP and_Conj (BaseAP (PositA cold_A) (PositA warm_A)) -LangEng: cold and warm -LangSwe: kall och varm -LangBul: студен и топъл - - -Lang: ConjNP or_Conj (BaseNP (UsePron she_Pron) (UsePron we_Pron)) -LangEng: she or we -LangSwe: hon eller vi -LangBul: тя или ние - - -Lang: ConjAdv or_Conj (BaseAdv here_Adv there_Adv) -LangEng: here or there -LangSwe: här eller där -LangBul: тук или там - - -Lang: ConjS either7or_DConj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV walk_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V)))) -LangEng: either he walks or she runs -LangSwe: antingen han går eller hon springer -LangBul: или той ходи или тя бяга - - -Lang: ConjAP both7and_DConj (BaseAP (PositA warm_A) (PositA cold_A)) -LangEng: both warm and cold -LangSwe: både varm och kall -LangBul: и топъл и студен - - -Lang: ConjNP either7or_DConj (BaseNP (UsePron he_Pron) (UsePron she_Pron)) -LangEng: either he or she -LangSwe: antingen han eller hon -LangBul: или той или тя - - -Lang: ConjAdv both7and_DConj (BaseAdv here_Adv there_Adv) -LangEng: both here and there -LangSwe: både här och där -LangBul: и тук и там - - -Lang: ImpersCl (UseComp (CompAP (PositA hot_A))) -LangEng: it is hot -LangSwe: det är hett -LangBul: е горещо - - -Lang: GenericCl (UseV sleep_V) -LangEng: one sleeps -LangSwe: man sover -LangBul: някой спи - - -Lang: CleftNP (UsePron i_Pron) (UseRCl (TTAnt TPast ASimul) PPos (RelVP IdRP (ComplSlash (SlashV2a do_V2) (UsePron it_Pron)))) -LangEng: it is I who did it -LangSwe: det är jag som gjorde det -LangBul: аз съм този който направих него - - -Lang: CleftAdv here_Adv (UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V))) -LangEng: it is here that she slept -LangSwe: det är här hon sov -LangBul: тук тя спа - - -Lang: ExistNP (DetCN (DetQuant IndefArt NumSg) (UseN house_N)) -LangEng: there is a house -LangSwe: det finns ett hus -LangBul: има къща - - -Lang: ExistIP (IdetCN (IdetQuant which_IQuant NumPl) (UseN house_N)) -LangEng: which houses are there -LangSwe: vilka hus finns det -LangBul: кои къщи са тук - - -Lang: PredVP (UsePron i_Pron) (ProgrVP (UseV sleep_V)) -LangEng: I am sleeping -LangSwe: jag håller på att sova -LangBul: аз спя - - -Lang: ImpPl1 (UseV go_V) -LangEng: let's go -LangSwe: låt oss gå -LangBul: нека да отидем - - -Lang: DetCN (DetQuant DefArt NumSg) (UseN man_N) -LangEng: the man -LangSwe: mannen -LangBul: мъжът - - -Lang: UsePN john_PN -LangEng: John -LangSwe: Johan -LangBul: Джон - - -Lang: UsePron he_Pron -LangEng: he -LangSwe: han -LangBul: той - - -Lang: PredetNP only_Predet (DetCN (DetQuant DefArt NumSg) (UseN man_N)) -LangEng: only the man -LangSwe: bara mannen -LangBul: само мъжът - - -Lang: PPartNP (DetCN (DetQuant DefArt NumSg) (UseN man_N)) see_V2 -LangEng: the man seen -LangSwe: mannen sedd -LangBul: мъжът видян - - -Lang: AdvNP (UsePN paris_PN) today_Adv -LangEng: Paris today -LangSwe: Paris idag -LangBul: Париж днес - - -Lang: RelNP (UsePN paris_PN) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (UseComp (CompAdv here_Adv)))) -LangEng: Paris , which is here -LangSwe: Paris , som är här -LangBul: Париж който е тук - - -Lang: DetNP (DetQuant this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) -LangEng: these five -LangSwe: de här fem -LangBul: тези пет - - -Lang: DetCN (DetQuantOrd this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))) (OrdSuperl good_A)) (UseN man_N) -LangEng: these five best men -LangSwe: de här fem bästa männen -LangBul: тези петима най - добри мъже - - -Lang: DetCN (DetQuant this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN man_N) -LangEng: these five men -LangSwe: de här fem männen -LangBul: тези петима мъже - - -Lang: DetCN (DetQuant this_Quant NumPl) (UseN man_N) -LangEng: these men -LangSwe: de här männen -LangBul: тези мъже - - -Lang: DetCN (DetQuant this_Quant NumSg) (UseN man_N) -LangEng: this man -LangSwe: den här mannen -LangBul: този мъж - - -Lang: NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))) -LangEng: five -LangSwe: fem -LangBul: пет - - -Lang: NumCard (NumDigits (IIDig D_5 (IDig D_1))) -LangEng: 5 1 -LangSwe: 5 1 -LangBul: 5 1 - - -Lang: NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot1plus n5 pot01))))) -LangEng: fifty - one -LangSwe: femtio en -LangBul: петдесет и един - - -Lang: NumCard (AdNum almost_AdN (NumDigits (IIDig D_5 (IDig D_1)))) -LangEng: almost 5 1 -LangSwe: nästan 5 1 -LangBul: почти 5 1 - - -Lang: OrdDigits (IIDig D_5 (IDig D_1)) -LangEng: 5 1st -LangSwe: 5 1:a -LangBul: 5 1ви - - -Lang: OrdNumeral (num (pot2as3 (pot1as2 (pot1plus n5 pot01)))) -LangEng: fifty - first -LangSwe: femtio första -LangBul: петдесет и първи - - -Lang: OrdSuperl warm_A -LangEng: warmest -LangSwe: varmaste -LangBul: най - топъл - - -Lang: DetCN (DetQuantOrd DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))) (OrdSuperl good_A)) (UseN man_N) -LangEng: the five best men -LangSwe: de fem bästa männen -LangBul: петимата най - добри мъже - - -Lang: DetCN (DetQuant DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN man_N) -LangEng: the five men -LangSwe: de fem männen -LangBul: петимата мъже - - -Lang: DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 pot01))))))) (UseN man_N) -LangEng: one man -LangSwe: en man -LangBul: един мъж - - -Lang: DetCN (DetQuant DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 pot01))))))) (UseN man_N) -LangEng: the one man -LangSwe: den en mannen -LangBul: единият мъж - - -Lang: DetCN (DetQuant DefArt NumSg) (UseN man_N) -LangEng: the man -LangSwe: mannen -LangBul: мъжът - - -Lang: DetCN (DetQuant DefArt NumPl) (UseN man_N) -LangEng: the men -LangSwe: männen -LangBul: мъжете - - -Lang: MassNP (UseN beer_N) -LangEng: beer -LangSwe: öl -LangBul: бира - - -Lang: DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN house_N) -LangEng: my house -LangSwe: mitt hus -LangBul: моята къща - - -Lang: UseN house_N -LangEng: house -LangSwe: hus -LangBul: къща - - -Lang: ComplN2 mother_N2 (DetCN (DetQuant DefArt NumSg) (UseN king_N)) -LangEng: mother of the king -LangSwe: mor till kungen -LangBul: майка на царя - - -Lang: ComplN2 (ComplN3 distance_N3 (DetCN (DetQuant this_Quant NumSg) (UseN city_N))) (UsePN paris_PN) -LangEng: distance from this city to Paris -LangSwe: avstånd från den här staden till Paris -LangBul: разстояние от този град до Париж - - -Lang: UseN2 mother_N2 -LangEng: mother -LangSwe: mor -LangBul: майка - - -Lang: ComplN2 (Use2N3 distance_N3) (DetCN (DetQuant this_Quant NumSg) (UseN city_N)) -LangEng: distance from this city -LangSwe: avstånd från den här staden -LangBul: разстояние от този град - - -Lang: ComplN2 (Use3N3 distance_N3) (UsePN paris_PN) -LangEng: distance to Paris -LangSwe: avstånd till Paris -LangBul: разстояние до Париж - - -Lang: UseN2 (Use2N3 distance_N3) -LangEng: distance -LangSwe: avstånd -LangBul: разстояние - - -Lang: AdjCN (PositA big_A) (UseN house_N) -LangEng: big house -LangSwe: stort hus -LangBul: голяма къща - - -Lang: RelCN (UseN house_N) (UseRCl (TTAnt TPast ASimul) PPos (RelSlash IdRP (SlashVP (UsePN john_PN) (SlashV2a buy_V2)))) -LangEng: house which John bought -LangSwe: hus som Johan köpte -LangBul: къща която Джон купи - - -Lang: AdvCN (UseN house_N) (PrepNP on_Prep (DetCN (DetQuant DefArt NumSg) (UseN hill_N))) -LangEng: house on the hill -LangSwe: hus på kullen -LangBul: къща на хълма - - -Lang: SentCN (UseN question_N) (EmbedQS (UseQCl (TTAnt TPres ASimul) PPos (QuestIAdv where_IAdv (PredVP (UsePron she_Pron) (UseV sleep_V))))) -LangEng: question where she sleeps -LangSwe: fråga var hon sover -LangBul: въпрос където тя спи - - -Lang: DetCN (DetQuant DefArt NumSg) (ApposCN (UseN city_N) (UsePN paris_PN)) -LangEng: the city Paris -LangSwe: staden Paris -LangBul: градът Париж - - -Lang: DetCN (DetQuant (PossPron i_Pron) NumSg) (ApposCN (UseN friend_N) (UsePN john_PN)) -LangEng: my friend John -LangSwe: min vän Johan -LangBul: моят приятел Джон - - -Lang: num (pot2as3 (pot1as2 (pot0as1 (pot0 n6)))) -LangEng: six -LangSwe: sex -LangBul: шест - - -Lang: num (pot2as3 (pot1as2 (pot0as1 pot01))) -LangEng: one -LangSwe: en -LangBul: един - - -Lang: num (pot2as3 (pot1as2 (pot1 n6))) -LangEng: sixty -LangSwe: sextio -LangBul: шестдесет - - -Lang: num (pot2as3 (pot1as2 pot110)) -LangEng: ten -LangSwe: tio -LangBul: десет - - -Lang: num (pot2as3 (pot1as2 pot111)) -LangEng: eleven -LangSwe: elva -LangBul: единадесет - - -Lang: num (pot2as3 (pot1as2 (pot1to19 n6))) -LangEng: sixteen -LangSwe: sexton -LangBul: шестнадесет - - -Lang: num (pot2as3 (pot1as2 (pot1 n6))) -LangEng: sixty -LangSwe: sextio -LangBul: шестдесет - - -Lang: num (pot2as3 (pot1as2 (pot1plus n6 (pot0 n5)))) -LangEng: sixty - five -LangSwe: sextio fem -LangBul: шестдесет и пет - - -Lang: num (pot2as3 (pot2 (pot0 n4))) -LangEng: four hundred -LangSwe: fyra hundra -LangBul: четиристотин - - -Lang: num (pot2as3 (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7)))) -LangEng: four hundred and sixty - seven -LangSwe: fyra hundra sextio sju -LangBul: четиристотин шестдесет и седем - - -Lang: num (pot3 (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7)))) -LangEng: four hundred and sixty - seven thousand -LangSwe: fyra hundra sextio sju tusen -LangBul: четиристотин шестдесет и седем хиляди - - -Lang: num (pot3plus (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7))) (pot1as2 (pot1plus n8 (pot0 n9)))) -LangEng: four hundred and sixty - seven thousand eighty - nine -LangSwe: fyra hundra sextio sju tusen åttio nio -LangBul: четиристотин шестдесет и седем хиляди осемдесет и девет - - -Lang: IDig D_8 -LangEng: 8 -LangSwe: 8 -LangBul: 8 - - -Lang: IIDig D_8 (IIDig D_0 (IIDig D_0 (IIDig D_1 (IIDig D_7 (IIDig D_8 (IDig D_9)))))) -LangEng: 8 , 0 0 1 , 7 8 9 -LangSwe: 8 0 0 1 7 8 9 -LangBul: 8 , 0 0 1 , 7 8 9 - - -Lang: PhrUtt but_PConj (UttImpSg PPos (ImpVP (AdvVP (UseV come_V) here_Adv))) (VocNP (DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN friend_N))) -LangEng: but come here , my friend -LangSwe: men kom här , min vän -LangBul: но ела тук , мой приятелю - - -Lang: PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePN john_PN) (UseV walk_V)))) NoVoc -LangEng: John walks -LangSwe: Johan går -LangBul: Джон ходи - - -Lang: UttQS (UseQCl (TTAnt TPres ASimul) PPos (QuestCl (PredVP (UsePron it_Pron) (UseComp (CompAP (PositA good_A)))))) -LangEng: is it good -LangSwe: är det gott -LangBul: то е ли добро - - -Lang: UttImpSg PNeg (ImpVP (ReflVP (SlashV2a love_V2))) -LangEng: don't love yourself -LangSwe: älska inte dig -LangBul: не се обичай - - -Lang: UttImpPl PNeg (ImpVP (ReflVP (SlashV2a love_V2))) -LangEng: don't love yourselves -LangSwe: älska inte er -LangBul: не се обичайте - - -Lang: UttImpPol PNeg (ImpVP (UseV sleep_V)) -LangEng: don't sleep -LangSwe: sov inte -LangBul: не спете - - -Lang: UttIP whoPl_IP -LangEng: who -LangSwe: vilka -LangBul: кои - - -Lang: UttIP whoSg_IP -LangEng: who -LangSwe: vem -LangBul: кой - - -Lang: UttIAdv why_IAdv -LangEng: why -LangSwe: varför -LangBul: защо - - -Lang: UttNP (DetCN (DetQuant this_Quant NumSg) (UseN man_N)) -LangEng: this man -LangSwe: den här mannen -LangBul: този мъж - - -Lang: UttAdv here_Adv -LangEng: here -LangSwe: här -LangBul: тук - - -Lang: UttVP (UseV sleep_V) -LangEng: to sleep -LangSwe: att sova -LangBul: да спи - - -Lang: VocNP (DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN friend_N)) -LangEng: , my friend -LangSwe: , min vän -LangBul: , мой приятелю - - -Lang: QuestCl (PredVP (UsePN john_PN) (UseV walk_V)) -LangEng: does John walk -LangSwe: går Johan -LangBul: Джон ходи ли - - -Lang: QuestVP whoSg_IP (UseV walk_V) -LangEng: who walks -LangSwe: vem går -LangBul: кой ходи - - -Lang: QuestSlash whoSg_IP (SlashVP (UsePN john_PN) (SlashV2a love_V2)) -LangEng: whom does John love -LangSwe: vem älskar Johan -LangBul: кого обича Джон - - -Lang: QuestIAdv why_IAdv (PredVP (UsePN john_PN) (UseV walk_V)) -LangEng: why does John walk -LangSwe: varför går Johan -LangBul: защо ходи Джон - - -Lang: QuestIComp (CompIAdv where_IAdv) (UsePN john_PN) -LangEng: where is John -LangSwe: var är Johan -LangBul: къде е Джон - - -Lang: IdetCN (IdetQuant which_IQuant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN song_N) -LangEng: which five songs -LangSwe: vilka fem sånger -LangBul: кои пет песни - - -Lang: IdetIP (IdetQuant which_IQuant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) -LangEng: which five -LangSwe: vilka fem -LangBul: кои пет - - -Lang: AdvIP whoSg_IP (PrepNP in_Prep (UsePN paris_PN)) -LangEng: who in Paris -LangSwe: vem i Paris -LangBul: кой в Париж - - -Lang: IdetIP (IdetQuant which_IQuant NumSg) -LangEng: which -LangSwe: vilket -LangBul: кое - - -Lang: PrepIP with_Prep whoSg_IP -LangEng: with whom -LangSwe: med vem -LangBul: с кой - - -Lang: QuestIComp (CompIAdv where_IAdv) (UsePron it_Pron) -LangEng: where is it -LangSwe: var är det -LangBul: къде е то - - -Lang: QuestIComp (CompIP whoSg_IP) (UsePron it_Pron) -LangEng: who is it -LangSwe: vem är det -LangBul: кой е то - - -Lang: ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelCl (PredVP (UsePN john_PN) (ComplSlash (SlashV2a love_V2) (UsePron she_Pron))))))) -LangEng: there is a woman such that John loves her -LangSwe: det finns en kvinna sådan att Johan älskar henne -LangBul: има жена такава че Джон обича нея - - -Lang: ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (ComplSlash (SlashV2a love_V2) (UsePN john_PN)))))) -LangEng: there is a woman who loves John -LangSwe: det finns en kvinna som älskar Johan -LangBul: има жена която обича Джон - - -Lang: ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePN john_PN) (SlashV2a love_V2)))))) -LangEng: there is a woman whom John loves -LangSwe: det finns en kvinna som Johan älskar -LangBul: има жена която Джон обича - - -Lang: ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash (FunRP possess_Prep (DetCN (DetQuant DefArt NumSg) (UseN2 mother_N2)) IdRP) (SlashVP (UsePN john_PN) (SlashV2a love_V2)))))) -LangEng: there is a woman the mother of whom John loves -LangSwe: det finns en kvinna modern av vilken Johan älskar -LangBul: има жена майката на която Джон обича - - -Lang: PredVP (UsePN john_PN) (UseV walk_V) -LangEng: John walks -LangSwe: Johan går -LangBul: Джон ходи - - -Lang: PredSCVP (EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV go_V)))) (UseComp (CompAP (PositA good_A))) -LangEng: that she goes is good -LangSwe: att hon går är gott -LangBul: , че тя отива е добър - - -Lang: RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron he_Pron) (SlashV2a see_V2)))) -LangEng: girl whom he sees -LangSwe: flicka som han ser -LangBul: момиче което той вижда - - -Lang: RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (AdvSlash (SlashVP (UsePron he_Pron) (SlashV2a see_V2)) today_Adv))) -LangEng: girl whom he sees today -LangSwe: flicka som han ser idag -LangBul: момиче което той вижда днес - - -Lang: RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashPrep (PredVP (UsePron he_Pron) (UseV walk_V)) with_Prep))) -LangEng: girl with whom he walks -LangSwe: flicka med vilken han går -LangBul: момиче с което той ходи - - -Lang: RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVS (UsePron she_Pron) say_VS (UseSlash (TTAnt TPres ASimul) PPos (SlashVP (UsePron he_Pron) (SlashV2a love_V2)))))) -LangEng: girl whom she says that he loves -LangSwe: flicka som hon säger att han älskar -LangBul: момиче което тя казва че той обича - - -Lang: ImpVP (ReflVP (SlashV2a love_V2)) -LangEng: love yourself -LangSwe: älska dig -LangBul: обичай се - - -Lang: EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV go_V))) -LangEng: that she goes -LangSwe: att hon går -LangBul: , че тя отива - - -Lang: EmbedQS (UseQCl (TTAnt TPres ASimul) PPos (QuestVP whoSg_IP (UseV go_V))) -LangEng: who goes -LangSwe: vem som går -LangBul: който отива - - -Lang: EmbedVP (UseV go_V) -LangEng: to go -LangSwe: att gå -LangBul: да отида - - -Lang: UseCl (TTAnt TCond AAnter) PNeg (PredVP (UsePN john_PN) (UseV walk_V)) -LangEng: John wouldn't have walked -LangSwe: Johan skulle inte ha gått -LangBul: Джон не би ходил - - -Lang: UseQCl (TTAnt TCond AAnter) PNeg (QuestCl (PredVP (UsePN john_PN) (UseV walk_V))) -LangEng: wouldn't John have walked -LangSwe: skulle Johan inte ha gått -LangBul: Джон не би ли ходил - - -Lang: RelCN (UseN girl_N) (UseRCl (TTAnt TCond AAnter) PNeg (RelVP IdRP (UseV walk_V))) -LangEng: girl who wouldn't have walked -LangSwe: flicka som inte skulle ha gått -LangBul: момиче което не би ходило - - -Lang: RelCN (UseN girl_N) (UseRCl (TTAnt TCond AAnter) PNeg (RelSlash IdRP (SlashPrep (PredVP (UsePron i_Pron) (UseV walk_V)) with_Prep))) -LangEng: girl with whom I wouldn't have walked -LangSwe: flicka med vilken jag inte skulle ha gått -LangBul: момиче с което аз не бих ходил - - -Lang: RelS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V))) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (UseComp (CompAP (PositA good_A))))) -LangEng: she sleeps , which is good -LangSwe: hon sover , som är gott -LangBul: тя спи , което е добро - - -Lang: TEmpty -LangEng: -LangSwe: -LangBul: - - -Lang: TFullStop (PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePN john_PN) (UseV walk_V)))) NoVoc) TEmpty -LangEng: John walks . -LangSwe: Johan går . -LangBul: Джон ходи . - - -Lang: TQuestMark (PhrUtt NoPConj (UttQS (UseQCl (TTAnt TPres ASimul) PPos (QuestCl (PredVP (UsePron they_Pron) (UseComp (CompAdv here_Adv)))))) NoVoc) TEmpty -LangEng: are they here ? -LangSwe: är de här ? -LangBul: те са ли тук ? - - -Lang: TExclMark (PhrUtt NoPConj (ImpPl1 (UseV go_V)) NoVoc) TEmpty -LangEng: let's go ! -LangSwe: låt oss gå ! -LangBul: нека да отидем ! - - -Lang: PredVP (UsePron i_Pron) (UseV sleep_V) -LangEng: I sleep -LangSwe: jag sover -LangBul: аз спя - - -Lang: PredVP (UsePron i_Pron) (ComplVV want_VV (UseV run_V)) -LangEng: I want to run -LangSwe: jag vill springa -LangBul: аз искам да бягам - - -Lang: PredVP (UsePron i_Pron) (ComplVS say_VS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V)))) -LangEng: I say that she runs -LangSwe: jag säger att hon springer -LangBul: аз казвам , че тя бяга - - -Lang: PredVP (UsePron i_Pron) (ComplVQ wonder_VQ (UseQCl (TTAnt TPres ASimul) PPos (QuestVP whoSg_IP (UseV run_V)))) -LangEng: I wonder who runs -LangSwe: jag undrar vem som springer -LangBul: аз се учудвам кой бяга - - -Lang: PredVP (UsePron they_Pron) (ComplVA become_VA (PositA red_A)) -LangEng: they become red -LangSwe: de blir röda -LangBul: те стават червени - - -Lang: PredVP (UsePron i_Pron) (ComplSlash (Slash3V3 give_V3 (UsePron he_Pron)) (UsePron it_Pron)) -LangEng: I give it to him -LangSwe: jag ger det till honom -LangBul: аз давам него му - - -Lang: PredVP (UsePron i_Pron) (ComplSlash (SlashV2V beg_V2V (UseV go_V)) (UsePron she_Pron)) -LangEng: I beg her to go -LangSwe: jag ber henne att gå -LangBul: аз моля нея да отиде - - -Lang: PredVP (UsePron i_Pron) (ComplSlash (SlashV2S answer_V2S (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron it_Pron) (UseComp (CompAP (PositA good_A)))))) (UsePron he_Pron)) -LangEng: I answer to him that it is good -LangSwe: jag svarar till honom att det är gott -LangBul: аз отговарям му , че то е добро - - -Lang: PredVP (UsePron i_Pron) (ComplSlash (SlashV2Q ask_V2Q (UseQCl (TTAnt TPast ASimul) PPos (QuestVP whoSg_IP (UseV come_V)))) (UsePron he_Pron)) -LangEng: I ask him who came -LangSwe: jag frågar honom vem som kom -LangBul: аз питам него кой дойде - - -Lang: PredVP (UsePron i_Pron) (ComplSlash (SlashV2A paint_V2A (PositA red_A)) (UsePron it_Pron)) -LangEng: I paint it red -LangSwe: jag målar det rött -LangBul: аз рисувам него червено - - -Lang: RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron i_Pron) (SlashVV want_VV (SlashV2a buy_V2))))) -LangEng: car which I want to buy -LangSwe: bil som jag vill köpa -LangBul: кола която аз искам да купя - - -Lang: RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron they_Pron) (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashV2a buy_V2))))) -LangEng: car which they beg me to buy -LangSwe: bil som de ber mig att köpa -LangBul: кола която те молят мен да купя - - -Lang: PredVP (UsePron he_Pron) (ReflVP (SlashV2a love_V2)) -LangEng: he loves himself -LangSwe: han älskar sig -LangBul: той се обича - - -Lang: PredVP (DetNP (DetQuant this_Quant NumSg)) (UseComp (CompAP (PositA warm_A))) -LangEng: this is warm -LangSwe: det här är varmt -LangBul: това е топло - - -Lang: PredVP (UsePron we_Pron) (PassV2 love_V2) -LangEng: we are loved -LangSwe: vi blir älskade -LangBul: ние сме обичани - - -Lang: PredVP (UsePron we_Pron) (AdvVP (UseV sleep_V) here_Adv) -LangEng: we sleep here -LangSwe: vi sover här -LangBul: ние спим тук - - -Lang: PredVP (UsePron we_Pron) (AdVVP always_AdV (UseV sleep_V)) -LangEng: we always sleep -LangSwe: vi sover alltid -LangBul: ние винаги спим - - -Lang: PredVP (UsePron we_Pron) (UseComp (CompAP (PositA small_A))) -LangEng: we are small -LangSwe: vi är små -LangBul: ние сме малки - - -Lang: PredVP (UsePron i_Pron) (UseComp (CompNP (DetCN (DetQuant IndefArt NumSg) (UseN man_N)))) -LangEng: I am a man -LangSwe: jag är en man -LangBul: аз съм мъж - - -Lang: PredVP (UsePron i_Pron) (UseComp (CompAdv here_Adv)) -LangEng: I am here -LangSwe: jag är här -LangBul: аз съм тук - - -Lang: RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron they_Pron) (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashVV want_VV (SlashV2A paint_V2A (PositA red_A))))))) -LangEng: car which they beg me to want to paint red -LangSwe: bil som de ber mig att vilja måla röd -LangBul: кола която те молят мен да искам да нарисувам червена - - -Lang: PhrUtt NoPConj (UttImpSg PPos (ImpVP (AdVVP always_AdV (ComplSlash (SlashV2a listen_V2) (DetCN (DetQuant DefArt NumSg) (UseN sea_N)))))) NoVoc -LangEng: always listen to the sea -LangSwe: lyssna alltid på havet -LangBul: винаги слушай морето - - -Lang: PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (ExistNP (PredetNP only_Predet (DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n2)))))))) (AdvCN (RelCN (UseN woman_N) (UseRCl (TTAnt TCond ASimul) PPos (RelSlash IdRP (SlashPrep (PredVP (UsePron i_Pron) (ComplVV want_VV (PassV2 see_V2))) with_Prep)))) (PrepNP in_Prep (DetCN (DetQuant DefArt NumSg) (UseN rain_N))))))))) NoVoc -LangEng: there are only two women with whom I would want to be seen in the rain -LangSwe: det finns bara två kvinnor med vilka jag skulle vilja bli sedd i regnet -LangBul: има само две жени с които аз бих искал да съм видян в дъжда - - -Lang: PhrUtt NoPConj (UttImpSg PPos (ImpVP (ComplSlash (SlashV2A paint_V2A (ConjAP both7and_DConj (BaseAP (ComparA small_A (DetCN (DetQuant DefArt NumSg) (UseN sun_N))) (ComparA big_A (DetCN (DetQuant DefArt NumSg) (UseN moon_N)))))) (DetCN (DetQuant DefArt NumSg) (UseN earth_N))))) NoVoc -LangEng: paint the earth both smaller than the sun and bigger than the moon -LangSwe: måla jorden både mindre än solen och större än månen -LangBul: нарисувай земята и по - малка от слънцето и по - голяма от луната - - -Lang: PhrUtt NoPConj (ImpPl1 (ComplVS hope_VS (ConjS either7or_DConj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumSg) (ComplN2 father_N2 (DetCN (DetQuant DefArt NumSg) (UseN baby_N)))) (UseV run_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumSg) (UseN2 (Use2N3 distance_N3))) (UseComp (CompAP (PositA small_A))))))))) NoVoc -LangEng: let's hope that either the father of the baby runs or the distance is small -LangSwe: låt oss hoppas att antingen fadern till bebisen springer eller avståndet är litet -LangBul: нека да се надяваме , че или бащата на бебето бяга или разстоянието е малко - - -Lang: PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN every_Det (UseN baby_N)) (UseComp (CompNP (ConjNP either7or_DConj (BaseNP (DetCN (DetQuant IndefArt NumSg) (UseN boy_N)) (DetCN (DetQuant IndefArt NumSg) (UseN girl_N))))))))) NoVoc -LangEng: every baby is either a boy or a girl -LangSwe: varje bebis är antingen en pojke eller en flicka -LangBul: всяко бебе е или момче или момиче - - -Lang: PhrUtt NoPConj (UttAdv (ConjAdv either7or_DConj (ConsAdv here7from_Adv (BaseAdv there_Adv everywhere_Adv)))) NoVoc -LangEng: either from here , there or everywhere -LangSwe: antingen härifrån , där eller överallt -LangBul: или от тук или там или навсякъде - - -Lang: PhrUtt NoPConj (UttVP (PassV2 know_V2)) NoVoc -LangEng: to be known -LangSwe: att bli kännd -LangBul: да е известно - - -Lang: RelCN (UseN bird_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron i_Pron) (SlashVV want_VV (SlashV2A paint_V2A (PositA red_A)))))) -LangEng: bird which I want to paint red -LangSwe: fågel som jag vill måla röd -LangBul: птица която аз искам да нарисувам червена - - -Lang: UttImpSg PPos (ImpVP (ComplVV want_VV (ComplSlash (SlashV2a buy_V2) (UsePron it_Pron)))) -LangEng: want to buy it -LangSwe: vilj köpa det -LangBul: искай да купиш него - - -Lang: UttImpSg PPos (ImpVP (ComplVV want_VV (ComplSlash (SlashV2A paint_V2A (PositA red_A)) (UsePron it_Pron)))) -LangEng: want to paint it red -LangSwe: vilj måla det rött -LangBul: искай да нарисуваш него червено - - -Lang: UttImpSg PPos (ImpVP (ComplSlash (SlashVV want_VV (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashV2a buy_V2))) (UsePron it_Pron))) -LangEng: want it to beg me to buy -LangSwe: vilj det be mig att köpa -LangBul: искай да молиш мен да купя него - - -Lang: PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumPl) (UseN fruit_N)) (ReflVP (Slash3V3 sell_V3 (DetCN (DetQuant DefArt NumSg) (UseN road_N))))))) NoVoc -LangEng: the fruits sell themselves to the road -LangSwe: frukterna säljer sig till vägen -LangBul: плодовете се продават на пътя - - -Lang: PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2V beg_V2V (UseV live_V)))))) NoVoc -LangEng: I beg myself to live -LangSwe: jag ber mig att leva -LangBul: аз се моля да живея - - -Lang: PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2S answer_V2S (UseCl (TTAnt TPres ASimul) PPos (ImpersCl (ComplVV must_VV (ReflVP (SlashV2a understand_V2)))))))))) NoVoc -LangEng: I answer to myself that it must understand itself -LangSwe: jag svarar till mig att det måste förstå sig -LangBul: аз си отговарям , че трябва да се разбере - - -Lang: PhrUtt NoPConj (UttImpSg PPos (ImpVP (ReflVP (SlashV2Q ask_V2Q (UseQCl (TTAnt TPast ASimul) PPos (QuestVP whoSg_IP (UseV come_V))))))) NoVoc -LangEng: ask yourself who came -LangSwe: fråga dig vem som kom -LangBul: питай се кой дойде - - -Lang: PhrUtt NoPConj (UttS (UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2A paint_V2A (ComparA beautiful_A (UsePN john_PN))))))) NoVoc -LangEng: I painted myself more beautiful than John -LangSwe: jag målade mig vackrare än Johan -LangBul: аз се нарисувах по - красив от Джон - - -Lang: UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant this_Quant NumSg) (UseN grammar_N)) (ComplSlash (SlashV2a speak_V2) (DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot1to19 n2))))))) (UseN language_N))))) -LangEng: this grammar speaks twelve languages -LangSwe: den här grammatiken talar tolv språk -LangBul: тази граматика говори дванадесет езика - - -Lang: UseCl (TTAnt TPast AAnter) PPos (PredVP (UsePron she_Pron) (ComplSlash (SlashV2a buy_V2) (DetCN (DetQuant IndefArt NumSg) (AdjCN (PositA red_A) (UseN house_N))))) -LangEng: she had bought a red house -LangSwe: hon hade köpt ett rött hus -LangBul: тя беше купилa червена къща - - diff --git a/testsuite/run.hs b/testsuite/run.hs index 6bf3c8158..f8e6bf49f 100644 --- a/testsuite/run.hs +++ b/testsuite/run.hs @@ -1,44 +1,35 @@ import Data.List(partition) import System.IO import Distribution.Simple.BuildPaths(exeExtension) -import Distribution.System ( buildPlatform ) +import Distribution.System(buildPlatform, OS (Windows), Platform (Platform) ) import System.Process(readProcess) import System.Directory(doesFileExist,getDirectoryContents) import System.FilePath((),(<.>),takeExtension) import System.Exit(exitSuccess,exitFailure) -main = +type TestResult = (FilePath, RunResult) +type RunResult = (String, (String, String, String)) -- (message, (input commands, gold output, actual output)) + +main :: IO () +main = do res <- walk "testsuite" let cnt = length res (good,bad) = partition ((=="OK").fst.snd) res - ok = length good + ok = length good + length (filter ((=="FAIL (expected)").fst.snd) bad) fail = ok IO [TestResult] +walk path = fmap concat . mapM (walkFile . (path )) =<< ls path where - toHTML res = - "\n" - ++ "\n" - ++ "\n" - ++ "\n
ResultInputGoldOutput\n" - ++ unlines (map testToHTML res) - ++ "
\n" - - testToHTML (in_file,(res,(input,gold,output))) = - ""++concatMap td [pre res,in_file++":\n"++pre input,pre gold,pre output] - pre s = "
"++s++"
" - td s = ""++s - - walk path = fmap concat . mapM (walkFile . (path )) =<< ls path - + walkFile :: FilePath -> IO [TestResult] walkFile fpath = do exists <- doesFileExist fpath if exists @@ -53,27 +44,71 @@ main = else return [] else walk fpath - runTest in_file out_file gold_file = do - input <- readFile in_file - writeFile out_file =<< run_gf input - exists <- doesFileExist gold_file - if exists - then do out <- compatReadFile out_file - gold <- compatReadFile gold_file - let info = (input,gold,out) - return $! if out == gold then ("OK",info) else ("FAIL",info) - else do out <- compatReadFile out_file - return ("MISSING GOLD",(input,"",out)) - -- Avoid failures caused by Win32/Unix text file incompatibility - compatReadFile path = - do h <- openFile path ReadMode - hSetNewlineMode h universalNewlineMode - hGetContents h +-- | Run an individual test +runTest :: FilePath -> FilePath -> FilePath -> IO RunResult +runTest in_file out_file gold_file = do + input <- readFile in_file + writeFile out_file =<< runGF ["-run"] input + exists <- doesFileExist gold_file + if exists + then do out <- compatReadFile out_file + gold <- compatReadFile gold_file + let info = (input,gold,out) + if in_file `elem` expectedFailures + then return $! if out == gold then ("Unexpected success",info) else ("FAIL (expected)",info) + else return $! if out == gold then ("OK",info) else ("FAIL",info) + else do out <- compatReadFile out_file + return ("MISSING GOLD",(input,"",out)) + +-- | Test scripts which should fail +expectedFailures :: [String] +expectedFailures = + [ "testsuite/runtime/parser/parser.gfs" -- Only parses `z` as `zero` and not also as e.g. `succ zero` as expected + , "testsuite/runtime/linearize/brackets.gfs" -- Missing "cannot linearize in the end" + , "testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs" -- Gives a different error than expected + ] + +-- | Produce HTML document with test results +toHTML :: [TestResult] -> String +toHTML res = + "\n" + ++ "\n" + ++ "\n" + ++ "\n
ResultInputGoldOutput\n" + ++ unlines (map testToHTML res) + ++ "
\n" + where + testToHTML (in_file,(res,(input,gold,output))) = + ""++concatMap td [pre res,in_file++":\n"++pre input,pre gold,pre output] + pre s = "
"++s++"
" + td s = ""++s + +-- | Run commands in GF shell, returning output +runGF + :: [String] -- ^ command line flags + -> String -- ^ standard input (shell commands) + -> IO String -- ^ standard output +runGF = readProcess defaultGF -- Should consult the Cabal configuration! -run_gf = readProcess default_gf ["-run","-gf-lib-path="++gf_lib_path] -default_gf = "dist/build/gf/gf"<.>exeExtension buildPlatform -gf_lib_path = "dist/build/rgl" +defaultGF :: FilePath +defaultGF = "gf"<.>exeExtension + where + -- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4 + exeExtension = case buildPlatform of + Platform arch Windows -> "exe" + _ -> "" -- | List files, excluding "." and ".." +ls :: FilePath -> IO [String] ls path = filter (`notElem` [".",".."]) `fmap` getDirectoryContents path + +-- | Avoid failures caused by Win32/Unix text file incompatibility +compatReadFile :: FilePath -> IO String +compatReadFile path = + do h <- openFile path ReadMode + hSetNewlineMode h universalNewlineMode + hGetContents h diff --git a/testsuite/runtime/linearize/brackets.gfs.gold b/testsuite/runtime/linearize/brackets.gfs.gold index e356e6521..7337daa9d 100644 --- a/testsuite/runtime/linearize/brackets.gfs.gold +++ b/testsuite/runtime/linearize/brackets.gfs.gold @@ -1,28 +1,19 @@ (S:2 (E:1 (_:0 ?1)) is even) - (S:3 exists x such that (S:2 (E:1 (_:0 x)) is even)) - (S:1 (E:0 a)) - (S:1 (E:0 aa) a) - (S:1 (E:0 a) b) - (S:1 (String:0 abcd) is string) - (S:1 (Int:0 100) is integer) - (S:1 (Float:0 12.4) is float) - (S:1 (String:0 xyz) is string) - -cannot linearize + cannot linearize diff --git a/testsuite/runtime/linearize/linearize.gfs.gold b/testsuite/runtime/linearize/linearize.gfs.gold index 8a17ab506..7749644f1 100644 --- a/testsuite/runtime/linearize/linearize.gfs.gold +++ b/testsuite/runtime/linearize/linearize.gfs.gold @@ -1,30 +1,20 @@ ?1 is even - exists x such that x is even - a - aa a - a b - abcd is string - 100 is integer - 12.4 is float - xyz is string - -