Minor additions to LPGF readme

Automatically upload release assets after building for release

.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:
@@ -53,19 +53,19 @@ jobs:
 
     - name: Build
       run: |
-        cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
+        cabal configure --enable-tests --test-show-details=direct
-        cabal build all
+        cabal build
 
-    # - name: Test
+    - name: Test
-    #   run: |
+      run: |
-    #     cabal test all
+        PATH="$PWD/dist/build/gf:$PATH" cabal test gf-tests
 
   stack:
     name: stack / ghc ${{ matrix.ghc }}
     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 }}
+        ghc-version: ${{ matrix.ghc }}
-        stack-version: ${{ matrix.stack }}
+        stack-version: 'latest'
+        enable-stack: true
 
     - uses: actions/cache@v1
       name: Cache ~/.stack
@@ -87,9 +88,8 @@ jobs:
 
     - name: Build
       run: |
-        stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
+        stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml --test --no-run-tests
-        # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
 
-    # - name: Test
+    - name: Test
-    #   run: |
+      run: |
-    #     stack test --system-ghc
+        stack test --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml gf:test:gf-tests

.github/workflows/build-binary-packages.yml

@@ -3,6 +3,7 @@ name: Build Binary Packages
 on:
   workflow_dispatch:
   release: 
+    types: ["created"]
 
 jobs:
 
@@ -10,11 +11,13 @@ jobs:
 
   ubuntu:
     name: Build Ubuntu package
-    runs-on: ubuntu-18.04
+    strategy:
-    # strategy:
+      matrix:
-    #   matrix:
+        os:
-    #     ghc: ["8.6.5"]
+        - ubuntu-18.04
-    #     cabal: ["2.4"]
+        - 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

.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')

.gitignore

@@ -5,6 +5,7 @@
 *.jar
 *.gfo
 *.pgf
+*.lpgf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf
@@ -48,11 +49,15 @@ src/runtime/java/.libs/
 src/runtime/python/build/
 .cabal-sandbox
 cabal.sandbox.config
-.stack-work
+.stack-work*
 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
@@ -69,3 +74,10 @@ doc/icfp-2012.html
 download/*.html
 gf-book/index.html
 src/www/gf-web-api.html
+
+DEBUG/
+PROF/
+*.aux
+*.hp
+*.prof
+*.ps

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
+ifeq ($(STACK),1)
-	cabal register
+	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
 

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)
+For more information, including links to precompiled binaries, see the [download page](http://www.grammaticalframework.org/download/index.html).
-and [developers manual](http://www.grammaticalframework.org/doc/gf-developers.html).
 
 ## About this repository
 

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 <https://hackage.haskell.org/upload> and upload the file `dist/gf-X.Y.tar.gz`

debian/changelog

@@ -1,3 +1,9 @@
+gf (3.11) bionic focal; urgency=low
+
+  * GF 3.11
+
+ -- Inari Listenmaa <inari@digitalgrammars.com>  Sun, 25 Jul 2021 10:27:40 +0800
+
 gf (3.10.4-1) xenial bionic cosmic; urgency=low
 
   * GF 3.10.4

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 v1-update
-	cabal install --only-dependencies
+	cabal v1-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-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

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
+```

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
+%**On Linux** the best option is to install the tools via the standard
-software distribution channels, i.e. by using the //Software Center//
+%software distribution channels, i.e. by using the //Software Center//
-in Ubuntu or the corresponding tool in other popular Linux distributions.
+%in Ubuntu or the corresponding tool in other popular Linux distributions.
-Or, from a Terminal window, the following command should be enough:
 
-- On Ubuntu: ``sudo apt-get install haskell-platform git libghc6-haskeline-dev``
+%**On Mac OS and Windows**, the tools can be downloaded from their respective
-- On Fedora: ``sudo dnf install haskell-platform git ghc-haskeline-devel``
+%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
+- **On other operating systems**, see the [installation guide https://docs.haskellstack.org/en/stable/install_and_upgrade].
-web sites, as described below.
 
-=== The Haskell Platform ===
 
-GF is written in Haskell, so first of all you need
+%If you already have Stack installed, upgrade it to the latest version by running: ``stack upgrade``
-the //Haskell Platform//, e.g. version 8.0.2 or 7.10.3. Downloads
-and installation instructions are available from here:
 
-    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//.
+To get the GF source code, you also need //Git//, a distributed version control system.
-//Git// is a distributed version control system, see
-https://git-scm.com/downloads for more information.
 
-=== 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 Mac OS and Windows**, this should work automatically.
-- On Fedora: ``sudo dnf install ghc-haskeline-devel``
+
+- **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
+Once you have all tools in place you can get the GF source code from
-just want to compile and use GF then it is enough to have read-only
+[GitHub https://github.com/GrammaticalFramework/]:
-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.
 
-=== 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-core.git
-$ git clone https://github.com/GrammaticalFramework/gf-rgl.git
+  $ git clone https://github.com/GrammaticalFramework/gf-rgl.git
 ```
 
-This will create directories ``gf-core`` and ``gf-rgl`` in the current directory.
+To get new updates, run the following anywhere in your local copy of the repository:
-
-
-==== 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:
 
 ```
-$ 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/<YOUR_USERNAME>/gf-core.git
 ```
 
-This creates a patch against the previous version and stores it in your
++ **Updating your copy —**
-local repository. You can record any number of changes before
+Once you have cloned your fork, you need to set up the main repository as a remote:
-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.
 
 ```
-$ 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``),
+  $ git pull upstream master
-- pushing changes to the fork,
+```
-- and finally sending a pull request.
+
++ **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
+== Compilation from source ==
-case, all you need to do to compile and install GF, after downloading the
+
-source code as described above, is
+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
+//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.//
-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
+== Compiling GF with C runtime system support ==
-//configure//, //build// and //install// steps.
 
-=== Configure ===
+The C runtime system is a separate implementation of the PGF runtime services.
-
-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.
 It makes it possible to work with very large, ambiguous grammars, using
-probabilistic models to obtain probable parses. The C run-time system might
+probabilistic models to obtain probable parses. The C runtime system might
-also be easier to use than the Haskell run-time system on certain platforms,
+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
+To install the C runtime 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``.
 
-When the C run-time system is installed, you can install GF with C run-time
+- **On Linux and Mac OS —**
-support by doing
+  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
+from the top directory (``gf-core``).
-   the C run-time system.
 
-- The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use
+If you use stack, uncomment the following lines in the ``stack.yaml`` file:
-  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).
 
-- ``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
+https://github.com/GrammaticalFramework/gf-core/actions/workflows/build-binary-packages.yml
-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.
 
-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 ====
+or
-
-Make sure the ``debian/changelog`` starts with an entry that describes the
-version you are building. Then run
 
 ```
-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
+testsuite is the ``testsuite/`` directory. It contains subdirectories
-themself contain GF batch files (with extension .gfs). The above command
+which themselves contain GF batch files (with extension ``.gfs``).
-searches the subdirectories of the testsuite/ directory for files with extension
+The above command searches the subdirectories of the ``testsuite/`` directory
-.gfs and when it finds one it is executed with the GF interpreter.
+for files with extension ``.gfs`` and when it finds one, it is executed with
-The output of the script is stored in file with extension .out and is compared
+the GF interpreter. The output of the script is stored in file with extension ``.out``
-with the content of the corresponding file with extension .gold, if there is one.
+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.
 
-Every time when you make some changes to GF that have to be tested, instead of
+Every time when you make some changes to GF that have to be tested,
-writing the commands by hand in the GF shell, add them to one .gfs file in the testsuite
+instead of writing the commands by hand in the GF shell, add them to one ``.gfs``
-and run the test. In this way you can use the same test later and we will be sure
+file in the testsuite subdirectory where its ``.gf`` file resides and run the test.
-that we will not incidentaly break your code later.
+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.

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

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.
+<!-- 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 the latest Hackage release (macOS, Linux, and WSL2 on Windows)
 
 [GF is on Hackage](http://hackage.haskell.org/package/gf), so under
 normal circumstances the procedure is fairly simple:
 
-1.  Install a recent version of the [Haskell Platform](http://hackage.haskell.org/platform) (see note below)
+1.  Install ghcup https://www.haskell.org/ghcup/
-2.  `cabal update`
+2.  `ghcup install ghc 8.10.4`
-3.  On Linux: install some C libraries from your Linux distribution (see note below)
+3.  `ghcup set ghc 8.10.4`
-4.  `cabal install gf`
+4.  `cabal update`
+5.  On Linux: install some C libraries from your Linux distribution (see note below)
+6.  `cabal install gf-3.11`
 
 You can also download the source code release from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases),
 and follow the instructions below under **Installing from the latest developer source code**.
@@ -74,17 +80,6 @@ so you might want to add this directory to your path (in `.bash_profile` or simi
 PATH=$HOME/.cabal/bin:$PATH
 ```
 
-**Build tools**
-
-In order to compile GF you need the build tools **Alex** and **Happy**.
-These can be installed via Cabal, e.g.:
-
-```
-cabal install alex happy
-```
-
-or obtained by other means, depending on your OS.
-
 **Haskeline**
 
 GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which
@@ -98,7 +93,7 @@ Here is one way to do this:
 **GHC version**
 
 The GF source code has been updated to compile with GHC versions 7.10 through to 8.8.
-
+-->
 ## 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.
+<!--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).
 

download/index.html

@@ -1,8 +1,8 @@
 <html>
 <head>
-  <meta http-equiv="refresh" content="0; URL=/download/index-3.10.html" />
+  <meta http-equiv="refresh" content="0; URL=/download/index-3.11.html" />
 </head>
 <body>
-  You are being redirected to <a href="index-3.10.html">the current version</a> of this page.
+  You are being redirected to <a href="index-3.11.html">the current version</a> of this page.
 </body>
 </html>

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.
+- Support for newer version of Ubuntu 20.04 in the precompiled binaries.
-- Bug fixes.
+- 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.

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.10.4
-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
 
 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,
+    base >= 4.9.1 && < 4.15,
-    Cabal >=1.22.0.0,
+    Cabal >= 1.22.0.0,
-    directory,
+    directory >= 1.3.0 && < 1.4,
-    filepath,
+    filepath >= 1.4.1 && < 1.5,
-    process >=1.0.1.1
+    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,32 @@ 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,
+    hashable >= 1.2.6 && < 1.4,
+    mtl >= 2.2.1 && < 2.3,
+    pretty >= 1.1.3 && < 1.2,
+    random >= 1.1 && < 1.3,
+    text >= 1.2.2 && < 1.3,
+    unordered-containers >= 0.2.8 && < 0.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:
@@ -104,11 +112,13 @@ Library
   ghc-prof-options: -fprof-auto
 
   exposed-modules:
+    LPGF
     PGF
     PGF.Internal
     PGF.Haskell
 
   other-modules:
+    LPGF.Internal
     PGF.Data
     PGF.Macros
     PGF.Binary
@@ -135,18 +145,28 @@ Library
 
   if flag(c-runtime)
     exposed-modules: PGF2
-    other-modules:   PGF2.FFI PGF2.Expr PGF2.Type
+    other-modules:
-                     GF.Interactive2 GF.Command.Commands2
+      PGF2.FFI
-    hs-source-dirs:  src/runtime/haskell-bind
+      PGF2.Expr
-    build-tools:     hsc2hs
+      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
+    c-sources: src/runtime/haskell-bind/utils.c
-    cc-options:      -std=c99
+    cc-options: -std=c99
 
 ---- GF compiler as a library:
 
-  build-depends: filepath, directory>=1.2, time,
+  build-depends:
-                 process, haskeline, parallel>=3, json
+    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 +177,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,13 +204,14 @@ 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
     GF.Compile.Export
     GF.Compile.GenerateBC
     GF.Compile.GeneratePMCFG
+    GF.Compile.GrammarToLPGF
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
     GF.Compile.Optimize
@@ -206,13 +234,13 @@ 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
     GF.Data.ErrM
     GF.Data.Graph
     GF.Data.Graphviz
+    GF.Data.IntMapBuilder
     GF.Data.Relation
     GF.Data.Str
     GF.Data.Utilities
@@ -273,12 +301,17 @@ Library
     cpp-options: -DC_RUNTIME
 
   if flag(server)
-    build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7,
+    build-depends:
-                   cgi>=3001.2.2.0
+      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 +328,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 +340,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
+  default-language: Haskell2010
-  build-depends: gf, base
+  build-depends:
+    gf,
+    base
   ghc-options: -threaded
 --ghc-options: -fwarn-unused-imports
 
@@ -337,19 +382,442 @@ Executable gf
   if impl(ghc>=8.2)
     ghc-options: -fhide-source-paths
 
-executable pgf-shell
+-- executable pgf-shell
---if !flag(c-runtime)
+-- --if !flag(c-runtime)
-  buildable: False
+--   buildable: False
-  main-is:             pgf-shell.hs
+--   main-is: pgf-shell.hs
-  hs-source-dirs:      src/runtime/haskell-bind/examples
+--   hs-source-dirs: src/runtime/haskell-bind/examples
-  build-depends:       gf, base, containers, mtl, lifted-base
+--   build-depends:
-  default-language:    Haskell2010
+--     gf,
-  if impl(ghc>=7.0)
+--     base,
-    ghc-options: -rtsopts
+--     containers,
+--     mtl,
+--     lifted-base
+--   default-language: Haskell2010
+--   if impl(ghc>=7.0)
+--     ghc-options: -rtsopts
 
 test-suite gf-tests
-  type:           exitcode-stdio-1.0
+  type: exitcode-stdio-1.0
-  main-is:        run.hs
+  main-is: run.hs
   hs-source-dirs: testsuite
-  build-depends:  base>=4.3 && <5, Cabal>=1.8, directory, filepath, process
+  build-depends:
-  default-language:    Haskell2010
+    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
+
+test-suite lpgf
+  type: exitcode-stdio-1.0
+  main-is: test.hs
+  hs-source-dirs:
+    src/compiler
+    src/runtime/haskell
+    testsuite/lpgf
+  other-modules:
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF
+    GF.Command.Abstract
+    GF.Command.CommandInfo
+    GF.Command.Commands
+    GF.Command.CommonCommands
+    GF.Command.Help
+    GF.Command.Importing
+    GF.Command.Interpreter
+    GF.Command.Messages
+    GF.Command.Parse
+    GF.Command.SourceCommands
+    GF.Command.TreeOperations
+    GF.Compile
+    GF.Compile.CFGtoPGF
+    GF.Compile.CheckGrammar
+    GF.Compile.Compute.Concrete
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
+    GF.Compile.ConcreteToHaskell
+    GF.Compile.ExampleBased
+    GF.Compile.Export
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToCanonical
+    GF.Compile.GrammarToLPGF
+    GF.Compile.GrammarToPGF
+    GF.Compile.Multi
+    GF.Compile.Optimize
+    GF.Compile.PGFtoHaskell
+    GF.Compile.PGFtoJava
+    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.ToAPI
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.Concrete
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.TC
+    GF.Compile.Update
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compiler
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.Graph
+    GF.Data.Graphviz
+    GF.Data.IntMapBuilder
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Data.XML
+    GF.Grammar
+    GF.Grammar.Analyse
+    GF.Grammar.Binary
+    GF.Grammar.BNFC
+    GF.Grammar.Canonical
+    GF.Grammar.CanonicalJSON
+    GF.Grammar.CFG
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Parser
+    GF.Grammar.PatternMatch
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.ShowTerm
+    GF.Grammar.Unify
+    GF.Grammar.Values
+    GF.Haskell
+    GF.Infra.BuildInfo
+    GF.Infra.CheckM
+    GF.Infra.Concurrency
+    GF.Infra.Dependencies
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.SIO
+    GF.Infra.UseIO
+    GF.Interactive
+    GF.JavaScript.AbsJS
+    GF.JavaScript.PrintJS
+    GF.Main
+    GF.Quiz
+    GF.Speech.CFGToFA
+    GF.Speech.FiniteState
+    GF.Speech.GSL
+    GF.Speech.JSGF
+    GF.Speech.PGFToCFG
+    GF.Speech.PrRegExp
+    GF.Speech.RegExp
+    GF.Speech.SISR
+    GF.Speech.SLF
+    GF.Speech.SRG
+    GF.Speech.SRGS_ABNF
+    GF.Speech.SRGS_XML
+    GF.Speech.VoiceXML
+    GF.Support
+    GF.System.Catch
+    GF.System.Concurrency
+    GF.System.Console
+    GF.System.Directory
+    GF.System.Process
+    GF.System.Signal
+    GF.Text.Clitics
+    GF.Text.Coding
+    GF.Text.Lexing
+    GF.Text.Pretty
+    GF.Text.Transliterations
+    LPGF
+    LPGF.Internal
+    PGF
+    PGF.Binary
+    PGF.ByteCode
+    PGF.CId
+    PGF.Data
+    PGF.Expr
+    PGF.Forest
+    PGF.Generate
+    PGF.Internal
+    PGF.Linearize
+    PGF.Macros
+    PGF.Morphology
+    PGF.OldBinary
+    PGF.Optimize
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Printer
+    PGF.Probabilistic
+    PGF.Tree
+    PGF.TrieMap
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Utilities
+    PGF.VisualizeTree
+    Paths_gf
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+  build-depends:
+    ansi-terminal >= 0.6.3 && < 0.12,
+    array >= 0.5.1 && < 0.6,
+    base >=4.6 && < 5,
+    bytestring >= 0.10.8 && < 0.11,
+    containers >= 0.5.7 && < 0.7,
+    directory >= 1.3.0 && < 1.4,
+    filepath >= 1.4.1 && < 1.5,
+    ghc-prim >= 0.5.0 && < 0.7,
+    hashable >= 1.2.6 && < 1.4,
+    haskeline >= 0.7.3 && < 0.9,
+    json >= 0.9.1 && < 0.11,
+    mtl >= 2.2.1 && < 2.3,
+    parallel >= 3.2.1.1 && < 3.3,
+    pretty >= 1.1.3 && < 1.2,
+    process >= 1.4.3 && < 1.7,
+    random >= 1.1 && < 1.3,
+    text >= 1.2.2 && < 1.3,
+    time >= 1.6.0 && < 1.10,
+    transformers-compat >= 0.5.1.4 && < 0.7,
+    unordered-containers >= 0.2.8 && < 0.3,
+    utf8-string >= 1.0.1.1 && < 1.1
+
+  if impl(ghc<8.0)
+    build-depends:
+      fail >= 4.9.0 && < 4.10
+
+  if os(windows)
+    build-depends:
+      Win32 >= 2.3.1.1 && < 2.7
+  else
+    build-depends:
+      unix >= 2.7.2 && < 2.8,
+      terminfo >=0.4.0 && < 0.5
+
+  default-language: Haskell2010
+
+benchmark lpgf-bench
+  type: exitcode-stdio-1.0
+  main-is: bench.hs
+  hs-source-dirs:
+    src/compiler
+    src/runtime/haskell
+    testsuite/lpgf
+  other-modules:
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF
+    GF.Command.Abstract
+    GF.Command.CommandInfo
+    GF.Command.Commands
+    GF.Command.CommonCommands
+    GF.Command.Help
+    GF.Command.Importing
+    GF.Command.Interpreter
+    GF.Command.Messages
+    GF.Command.Parse
+    GF.Command.SourceCommands
+    GF.Command.TreeOperations
+    GF.Compile
+    GF.Compile.CFGtoPGF
+    GF.Compile.CheckGrammar
+    GF.Compile.Compute.Concrete
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
+    GF.Compile.ConcreteToHaskell
+    GF.Compile.ExampleBased
+    GF.Compile.Export
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToCanonical
+    GF.Compile.GrammarToLPGF
+    GF.Compile.GrammarToPGF
+    GF.Compile.Multi
+    GF.Compile.Optimize
+    GF.Compile.PGFtoHaskell
+    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoJava
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.ToAPI
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.Concrete
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.TC
+    GF.Compile.Update
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compiler
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.Graph
+    GF.Data.Graphviz
+    GF.Data.IntMapBuilder
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Data.XML
+    GF.Grammar
+    GF.Grammar.Analyse
+    GF.Grammar.BNFC
+    GF.Grammar.Binary
+    GF.Grammar.CFG
+    GF.Grammar.Canonical
+    GF.Grammar.CanonicalJSON
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Parser
+    GF.Grammar.PatternMatch
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.ShowTerm
+    GF.Grammar.Unify
+    GF.Grammar.Values
+    GF.Haskell
+    GF.Infra.BuildInfo
+    GF.Infra.CheckM
+    GF.Infra.Concurrency
+    GF.Infra.Dependencies
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.SIO
+    GF.Infra.UseIO
+    GF.Interactive
+    GF.JavaScript.AbsJS
+    GF.JavaScript.PrintJS
+    GF.Main
+    GF.Quiz
+    GF.Speech.CFGToFA
+    GF.Speech.FiniteState
+    GF.Speech.GSL
+    GF.Speech.JSGF
+    GF.Speech.PGFToCFG
+    GF.Speech.PrRegExp
+    GF.Speech.RegExp
+    GF.Speech.SISR
+    GF.Speech.SLF
+    GF.Speech.SRG
+    GF.Speech.SRGS_ABNF
+    GF.Speech.SRGS_XML
+    GF.Speech.VoiceXML
+    GF.Support
+    GF.System.Catch
+    GF.System.Concurrency
+    GF.System.Console
+    GF.System.Directory
+    GF.System.Process
+    GF.System.Signal
+    GF.Text.Clitics
+    GF.Text.Coding
+    GF.Text.Lexing
+    GF.Text.Pretty
+    GF.Text.Transliterations
+    LPGF
+    LPGF.Internal
+    PGF
+    PGF.Binary
+    PGF.ByteCode
+    PGF.CId
+    PGF.Data
+    PGF.Expr
+    PGF.Expr
+    PGF.Forest
+    PGF.Generate
+    PGF.Internal
+    PGF.Linearize
+    PGF.Macros
+    PGF.Morphology
+    PGF.OldBinary
+    PGF.Optimize
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Printer
+    PGF.Probabilistic
+    PGF.Tree
+    PGF.TrieMap
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Utilities
+    PGF.VisualizeTree
+    PGF2
+    PGF2.Expr
+    PGF2.Type
+    PGF2.FFI
+    Paths_gf
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+
+  hs-source-dirs:
+    src/runtime/haskell-bind
+  other-modules:
+    PGF2
+    PGF2.FFI
+    PGF2.Expr
+    PGF2.Type
+  build-tools:     hsc2hs
+  extra-libraries: pgf gu
+  c-sources:       src/runtime/haskell-bind/utils.c
+  cc-options:      -std=c99
+
+  build-depends:
+    ansi-terminal,
+    array,
+    base>=4.6 && <5,
+    bytestring,
+    containers,
+    deepseq,
+    directory,
+    filepath,
+    ghc-prim,
+    hashable,
+    haskeline,
+    json,
+    mtl,
+    parallel>=3,
+    pretty,
+    process,
+    random,
+    terminfo,
+    text,
+    time,
+    transformers-compat,
+    unix,
+    unordered-containers,
+    utf8-string
+  default-language: Haskell2010

index.html

@@ -214,9 +214,9 @@ least one, it may help you to get a first idea of what GF is.
     </p>
 
     <p>
-    We run the IRC channel <strong><code>#gf</code></strong> on the Freenode network, where you are welcome to look for help with small questions or just start a general discussion.
+    We run the IRC channel <strong><code>#gf</code></strong> on the Libera network, where you are welcome to look for help with small questions or just start a general discussion.
-    You can <a href="https://webchat.freenode.net/?channels=gf">open a web chat</a>
+    You can <a href="https://web.libera.chat/?channels=#gf">open a web chat</a>
-    or <a href="/irc/">browse the channel logs</a>.
+    or <a href="https://www.grammaticalframework.org/irc/?C=M;O=D">browse the channel logs</a>.
     </p>
     <p>
     If you have a larger question which the community may benefit from, we recommend you ask it on the <a href="http://groups.google.com/group/gf-dev">mailing list</a>.
@@ -226,11 +226,19 @@ least one, it may help you to get a first idea of what GF is.
 
   <div class="col-md-6">
     <h2>News</h2>
-
+    <dt class="col-sm-3 text-center text-nowrap">2021-07-25</dt>
+    <dd class="col-sm-9">
+      <strong>GF 3.11 released.</strong>
+      <a href="download/release-3.11.html">Release notes</a>
+    </dd>
     <dl class="row">
+      <dt class="col-sm-3 text-center text-nowrap">2021-05-05</dt>
+      <dd class="col-sm-9">
+        <a href="https://cloud.grammaticalframework.org/wordnet/">GF WordNet</a> now supports languages for which there are no other WordNets. New additions: Afrikaans, German, Korean, Maltese, Polish, Somali, Swahili.
+      </dd>
       <dt class="col-sm-3 text-center text-nowrap">2021-03-01</dt>
       <dd class="col-sm-9">
-        <a href="//school.grammaticalframework.org/2020/">Seventh GF Summer School</a>, in Singapore and online, 26 July &ndash; 8 August 2021.
+        <a href="//school.grammaticalframework.org/2020/">Seventh GF Summer School</a>, in Singapore and online, 26 July &ndash; 6 August 2021.
       </dd>
       <dt class="col-sm-3 text-center text-nowrap">2020-09-29</dt>
       <dd class="col-sm-9">

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

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")
        ],

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.Compute.Concrete(normalForm,resourceValues)
-import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
+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

src/compiler/GF/Compile.hs

@@ -1,6 +1,7 @@
-module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
+module GF.Compile (compileToPGF, compileToLPGF, link, linkl, batchCompile, srcAbsName) where
 
 import GF.Compile.GrammarToPGF(mkCanon2pgf)
+import GF.Compile.GrammarToLPGF(mkCanon2lpgf)
 import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
                             importsOfModule)
 import GF.CompileOne(compileOne)
@@ -14,7 +15,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
                       justModuleName,extendPathEnv,putStrE,putPointE)
 import GF.Data.Operations(raise,(+++),err)
 
-import Control.Monad(foldM,when,(<=<),filterM,liftM)
+import Control.Monad(foldM,when,(<=<),filterM)
 import GF.System.Directory(doesFileExist,getModificationTime)
 import System.FilePath((</>),isRelative,dropFileName)
 import qualified Data.Map as Map(empty,insert,elems) --lookup
@@ -24,12 +25,16 @@ import GF.Text.Pretty(render,($$),(<+>),nest)
 
 import PGF.Internal(optimizePGF)
 import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
+import LPGF(LPGF)
 
 -- | Compiles a number of source files and builds a 'PGF' structure for them.
 -- This is a composition of 'link' and 'batchCompile'.
 compileToPGF :: Options -> [FilePath] -> IOE PGF
 compileToPGF opts fs = link opts . snd =<< batchCompile opts fs
 
+compileToLPGF :: Options -> [FilePath] -> IOE LPGF
+compileToLPGF opts fs = linkl opts . snd =<< batchCompile opts fs
+
 -- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
 -- 'PGF.parse' with the "PGF" run-time system.
 link :: Options -> (ModuleName,Grammar) -> IOE PGF
@@ -42,6 +47,14 @@ link opts (cnc,gr) =
     return $ setProbabilities probs
            $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
 
+-- | Link a grammar into a 'LPGF' that can be used for linearization only.
+linkl :: Options -> (ModuleName,Grammar) -> IOE LPGF
+linkl opts (cnc,gr) =
+  putPointE Normal opts "linking ... " $ do
+    let abs = srcAbsName gr cnc
+    lpgf <- mkCanon2lpgf opts gr abs
+    return lpgf
+
 -- | Returns the name of the abstract syntax corresponding to the named concrete syntax
 srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
 

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty
 
 mkRuleName rule =
   case ruleName rule of
-	CFObj n _ -> n
+    CFObj n _ -> n
-	_         -> wildCId
+    _         -> wildCId

src/compiler/GF/Compile/CheckGrammar.hs

@@ -27,9 +27,9 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.RConcrete
+import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
-import qualified GF.Compile.TypeCheck.ConcreteNew as CN
+import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
-import qualified GF.Compile.Compute.ConcreteNew as CN
+import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -175,7 +175,7 @@ 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)
 
@@ -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 $$

src/compiler/GF/Compile/Compute/Concrete.hs

@@ -1,3 +1,590 @@
-module GF.Compile.Compute.Concrete{-(module M)-} where
+-- | Functions for computing the values of terms in the concrete syntax, in
---import GF.Compile.Compute.ConcreteLazy as M -- New
+-- | preparation for PMCFG generation.
---import GF.Compile.Compute.ConcreteStrict as M -- Old, inefficient
+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<length xs = Vr (reverse xs !! j)
+      | otherwise   = error ("variable #"++show j++" is out of scope")
+
+
+    pushs xs e = foldr push e xs
+    push x (env,xs) = ((x,gen xs):env,x:xs)
+    gen xs = VGen (length xs) []
+
+    nfcase (p,f) = (,) p (v2txs xs' (bind f env'))
+      where (env',xs') = pushs (pattVars p) ([],xs)
+
+    bind (Bind f) x = if stop
+                      then VSort (identS "...") -- hmm
+                      else f x
+
+
+linPattVars p =
+    if null dups
+    then return pvs
+    else fail.render $ hang "Pattern is not linear. All variable names on the left-hand side must be distinct." 4 (ppPatt Unqualified 0 p)
+  where
+    allpvs = allPattVars p
+    pvs = nub allpvs
+    dups = allpvs \\ pvs
+
+pattVars = nub . allPattVars
+allPattVars p =
+    case p of
+      PV i    -> [i]
+      PAs i p -> i:allPattVars p
+      _       -> collectPattOp allPattVars p
+
+---
+ix loc fn xs i =
+    if i<n
+    then xs !! i
+    else bugloc loc $ "(!!): index too large in "++fn++", "++show i++"<"++show n
+  where n = length xs
+
+infixl 1 #,<# --,@@
+
+f # x = fmap f x
+mf <# mx  = ap mf mx
+--m1 @@ m2 = (m1 =<<) . m2
+
+both f (x,y) = (,) # f x <# f y
+
+bugloc loc s = ppbug $ ppL loc s
+
+bug msg = ppbug msg
+ppbug doc = error $ render $ hang "Internal error in Compute.Concrete:" 4 doc

src/compiler/GF/Compile/Compute/ConcreteNew.hs

@@ -1,588 +0,0 @@
--- | Functions for computing the values of terms in the concrete syntax, in
--- | preparation for PMCFG generation.
-module GF.Compile.Compute.ConcreteNew
-           (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 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<length xs = Right (Vr (reverse xs !! j))
-      | otherwise   = Left  j
-
-
-    pushs xs e = foldr push e xs
-    push x (env,xs) = ((x,gen xs):env,x:xs)
-    gen xs = VGen (length xs) []
-
-    nfcase (p,f) = liftM ((,) p) (v2txs xs' (bind f env'))
-      where (env',xs') = pushs (pattVars p) ([],xs)
-
-    bind (Bind f) x = if stop
-                      then VSort (identS "...") -- hmm
-                      else f x
-
-
-linPattVars p =
-    if null dups
-    then return pvs
-    else fail.render $ hang "Pattern is not linear. All variable names on the left-hand side must be distinct." 4 (ppPatt Unqualified 0 p)
-  where
-    allpvs = allPattVars p
-    pvs = nub allpvs
-    dups = allpvs \\ pvs
-
-pattVars = nub . allPattVars
-allPattVars p =
-    case p of
-      PV i    -> [i]
-      PAs i p -> i:allPattVars p
-      _       -> collectPattOp allPattVars p
-
----
-ix loc fn xs i =
-    if i<n
-    then xs !! i
-    else bugloc loc $ "(!!): index too large in "++fn++", "++show i++"<"++show n
-  where n = length xs
-
-infixl 1 #,<# --,@@
-
-f # x = fmap f x
-mf <# mx  = ap mf mx
---m1 @@ m2 = (m1 =<<) . m2
-
-both f (x,y) = (,) # f x <# f y
-
-bugloc loc s = ppbug $ ppL loc s
-
-bug msg = ppbug msg
-ppbug doc = error $ render $ hang "Internal error in Compute.ConcreteNew:" 4 doc

src/compiler/GF/Compile/Compute/Predef.hs

@@ -27,6 +27,10 @@ instance Predef Int where
 
 instance Predef Bool where
   toValue = boolV
+  fromValue v = case v of
+    VCApp (mn,i) [] | mn == cPredef && i == cPTrue -> return True
+    VCApp (mn,i) [] | mn == cPredef && i == cPFalse -> return False
+    _ -> verror "Bool" v
 
 instance Predef String where
   toValue = string

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
+  | VAbs BindType Ident Binding -- used in Compute.Concrete
-  | VProd BindType Value Ident Binding -- used in Compute.ConcreteNew
+  | VProd BindType Value Ident Binding -- used in Compute.Concrete
   | VInt Int
   | VFloat Double
   | VString String

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
@@ -321,7 +321,7 @@ coerce env ty t =
       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 ParamId where toIdent (ParamId q) = qIdentC q
-instance ToIdent PredefId where toIdent (PredefId s) = identS s
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
-instance ToIdent CatId   where toIdent (CatId s) = identS s
+instance ToIdent CatId   where toIdent (CatId s) = identC s
-instance ToIdent C.FunId where toIdent (FunId s) = identS s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
-instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
 
-qIdentS = identS . unqual
+qIdentC = identS . unqual
 
-unqual (Qual (ModId m) n) = m++"_"++n
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
-unqual (Unqual n) = n
+unqual (Unqual n) = showRawIdent n
 
 instance ToIdent VarId where
   toIdent Anonymous = identW
-  toIdent (VarId s) = identS s
+  toIdent (VarId s) = identC s

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

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.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
-import GF.Infra.Option(optionsPGF)
+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,23 +60,24 @@ 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]
+      [lincat | (_,Left lincat) <- defs]
-      [lin|(_,Right lin)<-defs]
+      [lin | (_,Right lin) <- defs]
   where
     defs = concatMap (toCanonical gr absname cenv) .
            M.toList $
@@ -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))
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
-        QC (m,n) -> ParamConstant (Param ((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)))
+        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
-        Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
+        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
-        _ -> error $ "Missing case in convType for: "++show t
+        _ -> 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
+lblId :: Label -> C.LabelId
-modId (MN m) = ModId (showIdent m)
+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 C.FunId where gId = C.FunId . ident2raw
-instance FromIdent CatId where gId = CatId . showIdent
+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)
+qual :: ModuleName -> Ident -> QualId
-unqual n = Unqual (showIdent n)
+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 =

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -0,0 +1,429 @@
+module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where
+
+import LPGF.Internal (LPGF (..))
+import qualified LPGF.Internal as L
+
+import PGF.CId
+import GF.Grammar.Grammar
+import qualified GF.Grammar.Canonical as C
+import GF.Compile.GrammarToCanonical (grammar2canonical)
+
+import GF.Data.Operations (ErrorMonad (..))
+import qualified GF.Data.IntMapBuilder as IntMapBuilder
+import GF.Infra.Ident (rawIdentS, showRawIdent)
+import GF.Infra.Option (Options)
+import GF.Infra.UseIO (IOE)
+import GF.Text.Pretty (pp, render)
+
+import Control.Applicative ((<|>))
+import Control.Monad (when, unless, forM, forM_)
+import qualified Control.Monad.State.Strict as CMS
+import Data.Either (lefts, rights)
+import Data.List (elemIndex)
+import qualified Data.List as L
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromJust, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Environment (lookupEnv)
+import System.FilePath ((</>), (<.>))
+import Text.Printf (printf)
+
+import qualified Debug.Trace
+trace x = Debug.Trace.trace ("> " ++ show x) (return ())
+
+mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
+mkCanon2lpgf opts gr am = do
+  debug <- isJust <$> lookupEnv "DEBUG"
+  when debug $ do
+    ppCanonical debugDir canon
+    dumpCanonical debugDir canon
+  (an,abs) <- mkAbstract ab
+  cncs     <- mapM (mkConcrete debug ab) cncs
+  let lpgf = LPGF {
+    L.absname = an,
+    L.abstract = abs,
+    L.concretes = Map.fromList cncs
+  }
+  when debug $ ppLPGF debugDir lpgf
+  return lpgf
+  where
+    canon@(C.Grammar ab cncs) = grammar2canonical opts am gr
+
+mkAbstract :: (ErrorMonad err) => C.Abstract -> err (CId, L.Abstract)
+mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {})
+
+mkConcrete :: (ErrorMonad err) => Bool -> C.Abstract -> C.Concrete -> err (CId, L.Concrete)
+mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params0 lincats0 lindefs0) = do
+  let
+    -- Some transformations on canonical grammar
+
+    params :: [C.ParamDef]
+    params = inlineParamAliases params0
+
+    lincats :: [C.LincatDef]
+    lincats = s:i:f:lincats0
+      where
+        ss = C.RecordType [C.RecordRow (C.LabelId (rawIdentS "s")) C.StrType]
+        s = C.LincatDef (C.CatId (rawIdentS "String")) ss
+        i = C.LincatDef (C.CatId (rawIdentS "Int")) ss
+        f = C.LincatDef (C.CatId (rawIdentS "Float")) ss
+
+    lindefs :: [C.LinDef]
+    lindefs =
+      [ C.LinDef funId varIds linValue
+      | (C.LinDef funId varIds linValue) <- lindefs0
+      , let Right linType = lookupLinType funId
+      ]
+
+    -- Builds maps for lookups
+
+    paramValueMap :: Map.Map C.ParamId C.ParamDef -- constructor -> definition
+    paramValueMap = Map.fromList [ (v,d) | d@(C.ParamDef _ vs) <- params, (C.Param v _) <- vs ]
+
+    lincatMap :: Map.Map C.CatId C.LincatDef
+    lincatMap = Map.fromList [ (cid,d) | d@(C.LincatDef cid _) <- lincats ]
+
+    funMap :: Map.Map C.FunId C.FunDef
+    funMap = Map.fromList [ (fid,d) | d@(C.FunDef fid _) <- funs ]
+
+    -- | Lookup paramdef
+    lookupParamDef :: C.ParamId -> Either String C.ParamDef
+    lookupParamDef pid = m2e (printf "Cannot find param definition: %s" (show pid)) (Map.lookup pid paramValueMap)
+
+    -- | Lookup lintype for a function
+    lookupLinType :: C.FunId -> Either String C.LinType
+    lookupLinType funId = do
+      fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap)
+      let (C.FunDef _ (C.Type _ (C.TypeApp catId _))) = fun
+      lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap)
+      let (C.LincatDef _ lt) = lincat
+      return lt
+
+    -- | Lookup lintype for a function's argument
+    lookupLinTypeArg :: C.FunId -> Int -> Either String C.LinType
+    lookupLinTypeArg funId argIx = do
+      fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap)
+      let (C.FunDef _ (C.Type args _)) = fun
+      let (C.TypeBinding _ (C.Type _ (C.TypeApp catId _))) = args !! argIx
+      lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap)
+      let (C.LincatDef _ lt) = lincat
+      return lt
+
+    -- Code generation
+
+    -- | Main code generation function
+    mkLin :: C.LinDef -> CodeGen (CId, L.LinFun)
+    mkLin (C.LinDef funId varIds linValue) = do
+      -- when debug $ trace funId
+      (lf, _) <- val2lin linValue
+      return (fi2i funId, lf)
+      where
+        val2lin :: C.LinValue -> CodeGen (L.LinFun, Maybe C.LinType)
+        val2lin lv = case lv of
+
+          C.ConcatValue v1 v2 -> do
+            (v1',t1) <- val2lin v1
+            (v2',t2) <- val2lin v2
+            return (L.Concat v1' v2', t1 <|> t2) -- t1 else t2
+
+          C.LiteralValue ll -> case ll of
+            C.FloatConstant f -> return (L.Token $ T.pack $ show f, Just C.FloatType)
+            C.IntConstant i -> return (L.Token $ T.pack $ show i, Just C.IntType)
+            C.StrConstant s -> return (L.Token $ T.pack s, Just C.StrType)
+
+          C.ErrorValue err -> return (L.Error err, Nothing)
+
+          C.ParamConstant (C.Param pid lvs) -> do
+            let
+              collectProjections :: C.LinValue -> CodeGen [L.LinFun]
+              collectProjections (C.ParamConstant (C.Param pid lvs)) = do
+                def <- lookupParamDef pid
+                let (C.ParamDef tpid defpids) = def
+                pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ]
+                rest <- mapM collectProjections lvs
+                return $ L.Ix (pidIx+1) : concat rest
+              collectProjections lv = do
+                (lf,_) <- val2lin lv
+                return [lf]
+            lfs <- collectProjections lv
+            let term = L.Tuple lfs
+            def <- lookupParamDef pid
+            let (C.ParamDef tpid _) = def
+            return (term, Just $ C.ParamType (C.ParamTypeId tpid))
+
+          C.PredefValue (C.PredefId pid) -> case showRawIdent pid of
+            "BIND" -> return (L.Bind, Nothing)
+            "SOFT_BIND" -> return (L.Bind, Nothing)
+            "SOFT_SPACE" -> return (L.Space, Nothing)
+            "CAPIT" -> return (L.Capit, Nothing)
+            "ALL_CAPIT" -> return (L.AllCapit, Nothing)
+            x -> Left $ printf "Unknown predef function: %s" x
+
+          C.RecordValue rrvs -> do
+            ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs ]
+            return (L.Tuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs ts])
+
+          C.TableValue lt trvs -> do
+            -- group the rows by "left-most" value
+            let
+              groupRow :: C.TableRowValue -> C.TableRowValue -> Bool
+              groupRow (C.TableRow p1 _) (C.TableRow p2 _) = groupPattern p1 p2
+
+              groupPattern :: C.LinPattern -> C.LinPattern -> Bool
+              groupPattern p1 p2 = case (p1,p2) of
+                (C.ParamPattern (C.Param pid1 _), C.ParamPattern (C.Param pid2 _)) -> pid1 == pid2 -- compare only constructors
+                (C.RecordPattern (C.RecordRow lid1 patt1:_), C.RecordPattern (C.RecordRow lid2 patt2:_)) -> groupPattern patt1 patt2 -- lid1 == lid2 necessarily
+                _ -> error $ printf "Mismatched patterns in grouping:\n%s\n%s" (show p1) (show p2)
+
+              grps :: [[C.TableRowValue]]
+              grps = L.groupBy groupRow trvs
+
+            -- remove one level of depth and recurse
+            let
+              handleGroup :: [C.TableRowValue] -> CodeGen (L.LinFun, Maybe C.LinType)
+              handleGroup [C.TableRow patt lv] =
+                case reducePattern patt of
+                  Just patt' -> do
+                    (lf,lt) <- handleGroup [C.TableRow patt' lv]
+                    return (L.Tuple [lf],lt)
+                  Nothing    -> val2lin lv
+              handleGroup rows = do
+                let rows' = map reduceRow rows
+                val2lin (C.TableValue lt rows') -- lt is wrong here, but is unused
+
+              reducePattern :: C.LinPattern -> Maybe C.LinPattern
+              reducePattern patt =
+                case patt of
+                  C.ParamPattern (C.Param _ []) -> Nothing
+                  C.ParamPattern (C.Param _ patts) -> Just $ C.ParamPattern (C.Param pid' patts')
+                    where
+                      C.ParamPattern (C.Param pid1 patts1) = head patts
+                      pid' = pid1
+                      patts' = patts1 ++ tail patts
+
+                  C.RecordPattern [] -> Nothing
+                  C.RecordPattern (C.RecordRow lid patt:rrs) ->
+                    case reducePattern patt of
+                      Just patt' -> Just $ C.RecordPattern (C.RecordRow lid patt':rrs)
+                      Nothing    -> if null rrs then Nothing else Just $ C.RecordPattern rrs
+
+                  _ -> error $ printf "Unhandled pattern in reducing: %s" (show patt)
+
+              reduceRow :: C.TableRowValue -> C.TableRowValue
+              reduceRow (C.TableRow patt lv) =
+                let Just patt' = reducePattern patt
+                in  C.TableRow patt' lv
+
+            -- ts :: [(L.LinFun, Maybe C.LinType)]
+            ts <- mapM handleGroup grps
+
+            -- return
+            let typ = case ts of
+                  (_, Just tst):_ -> Just $ C.TableType lt tst
+                  _ -> Nothing
+            return (L.Tuple (map fst ts), typ)
+
+          -- TODO TuplePattern, WildPattern?
+
+          C.TupleValue lvs -> do
+            ts <- mapM val2lin lvs
+            return (L.Tuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts))
+
+          C.VariantValue [] -> return (L.Empty, Nothing) -- TODO Just C.StrType ?
+          C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first
+
+          C.VarValue (C.VarValueId (C.Unqual v)) -> do
+            ix <- eitherElemIndex (C.VarId v) varIds
+            lt <- lookupLinTypeArg funId ix
+            return (L.Argument (ix+1), Just lt)
+
+          C.PreValue pts df -> do
+            pts' <- forM pts $ \(pfxs, lv) -> do
+              (lv', _) <- val2lin lv
+              return (map T.pack pfxs, lv')
+            (df', lt) <- val2lin df
+            return (L.Pre pts' df', lt)
+
+          C.Projection v1 lblId -> do
+            (v1', mtyp) <- val2lin v1
+            -- find label index in argument type
+            let Just (C.RecordType rrs) = mtyp
+            let rrs' = [ lid | C.RecordRow lid _ <- rrs ]
+            -- lblIx <- eitherElemIndex lblId rrs'
+            let
+              lblIx = case eitherElemIndex lblId rrs' of
+                Right x -> x
+                Left _ -> 0 -- corresponds to Prelude.False
+            -- lookup lintype for record row
+            let C.RecordRow _ lt = rrs !! lblIx
+            return (L.Projection v1' (L.Ix (lblIx+1)), Just lt)
+
+          C.Selection v1 v2 -> do
+            (v1', t1) <- val2lin v1
+            (v2', t2) <- val2lin v2
+            let Just (C.TableType t11 t12) = t1 -- t11 == t2
+            return (L.Projection v1' v2', Just t12)
+
+          -- C.CommentedValue cmnt lv -> val2lin lv
+          C.CommentedValue cmnt lv -> case cmnt of
+            "impossible" -> return (L.Empty, Nothing)
+            -- "impossible" -> val2lin lv >>= \(_, typ) -> return (L.Empty, typ)
+            _ -> val2lin lv
+
+          v -> Left $ printf "val2lin not implemented for: %s" (show v)
+
+  -- Invoke code generation
+
+  let es = map mkLin lindefs
+  unless (null $ lefts es) (raise $ unlines (lefts es))
+
+  let maybeOptimise = if debug then id else extractStrings
+  let concr = maybeOptimise $ L.Concrete {
+    L.toks = IntMapBuilder.emptyIntMap,
+    L.lins = Map.fromList (rights es)
+  }
+  return (mdi2i modId, concr)
+
+type CodeGen a = Either String a
+
+-- | Remove ParamAliasDefs by inlining their definitions
+inlineParamAliases :: [C.ParamDef] -> [C.ParamDef]
+inlineParamAliases defs = if null aliases then defs else map rp' pdefs
+  where
+    (aliases,pdefs) = L.partition isParamAliasDef defs
+
+    rp' :: C.ParamDef -> C.ParamDef
+    rp' (C.ParamDef pid pids) = C.ParamDef pid (map rp'' pids)
+    rp' (C.ParamAliasDef _ _) = error "inlineParamAliases called on ParamAliasDef" -- impossible
+
+    rp'' :: C.ParamValueDef -> C.ParamValueDef
+    rp'' (C.Param pid pids) = C.Param pid (map rp''' pids)
+
+    rp''' :: C.ParamId -> C.ParamId
+    rp''' pid = case L.find (\(C.ParamAliasDef p _) -> p == pid) aliases of
+      Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p
+      _ -> pid
+
+isParamAliasDef :: C.ParamDef -> Bool
+isParamAliasDef (C.ParamAliasDef _ _) = True
+isParamAliasDef _ = False
+
+isParamType :: C.LinType -> Bool
+isParamType (C.ParamType _) = True
+isParamType _ = False
+
+isRecordType :: C.LinType -> Bool
+isRecordType (C.RecordType _) = True
+isRecordType _ = False
+
+-- | Find all token strings, put them in a map and replace with token indexes
+extractStrings :: L.Concrete -> L.Concrete
+extractStrings concr = L.Concrete { L.toks = toks', L.lins = lins' }
+  where
+    imb = IntMapBuilder.fromIntMap (L.toks concr)
+    (lins',imb') = CMS.runState (go0 (L.lins concr)) imb
+    toks' = IntMapBuilder.toIntMap imb'
+
+    go0 :: Map.Map CId L.LinFun -> CMS.State (IntMapBuilder.IMB Text) (Map.Map CId L.LinFun)
+    go0 mp = do
+      xs <- mapM (\(cid,lin) -> go lin >>= \lin' -> return (cid,lin')) (Map.toList mp)
+      return $ Map.fromList xs
+
+    go :: L.LinFun -> CMS.State (IntMapBuilder.IMB Text) L.LinFun
+    go lf = case lf of
+      L.Token str -> do
+        imb <- CMS.get
+        let (ix,imb') = IntMapBuilder.insert' str imb
+        CMS.put imb'
+        return $ L.TokenIx ix
+
+      L.Pre pts df -> do
+        -- pts' <- mapM (\(pfxs,lv) -> go lv >>= \lv' -> return (pfxs,lv')) pts
+        pts' <- forM pts $ \(pfxs,lv) -> do
+          imb <- CMS.get
+          let str = T.pack $ show pfxs
+          let (ix,imb') = IntMapBuilder.insert' str imb
+          CMS.put imb'
+          lv' <- go lv
+          return (ix,lv')
+        df' <- go df
+        return $ L.PreIx pts' df'
+      L.Concat s t -> do
+        s' <- go s
+        t' <- go t
+        return $ L.Concat s' t'
+      L.Tuple ts -> do
+        ts' <- mapM go ts
+        return $ L.Tuple ts'
+      L.Projection t u -> do
+        t' <- go t
+        u' <- go u
+        return $ L.Projection t' u'
+      t -> return t
+
+-- | Convert Maybe to Either value with error
+m2e :: String -> Maybe a -> Either String a
+m2e err = maybe (Left err) Right
+
+-- | Wrap elemIndex into Either value
+eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
+eitherElemIndex x xs = m2e (printf "Cannot find: %s in %s" (show x) (show xs)) (elemIndex x xs)
+
+mdi2s :: C.ModId -> String
+mdi2s (C.ModId i) = showRawIdent i
+
+mdi2i :: C.ModId -> CId
+mdi2i (C.ModId i) = mkCId (showRawIdent i)
+
+fi2i :: C.FunId -> CId
+fi2i (C.FunId i) = mkCId (showRawIdent i)
+
+-- Debugging
+
+debugDir :: FilePath
+debugDir = "DEBUG"
+
+-- | Pretty-print canonical grammars to file
+ppCanonical :: FilePath -> C.Grammar -> IO ()
+ppCanonical path (C.Grammar ab cncs) = do
+  let (C.Abstract modId flags cats funs) = ab
+  writeFile (path </> mdi2s modId <.> "canonical.gf") (render $ pp ab)
+  forM_ cncs $ \cnc@(C.Concrete modId absModId flags params lincats lindefs) ->
+    writeFile' (path </> mdi2s modId <.> "canonical.gf") (render $ pp cnc)
+
+-- | Dump canonical grammars to file
+dumpCanonical :: FilePath -> C.Grammar -> IO ()
+dumpCanonical path (C.Grammar ab cncs) = do
+  let (C.Abstract modId flags cats funs) = ab
+  let body = unlines $ map show cats ++ [""] ++ map show funs
+  writeFile' (path </> mdi2s modId <.> "canonical.dump") body
+
+  forM_ cncs $ \(C.Concrete modId absModId flags params lincats lindefs) -> do
+    let body = unlines $ concat [
+          map show params,
+          [""],
+          map show lincats,
+          [""],
+          map show lindefs
+          ]
+    writeFile' (path </> mdi2s modId <.> "canonical.dump") body
+
+-- | Pretty-print LPGF to file
+ppLPGF :: FilePath -> LPGF -> IO ()
+ppLPGF path lpgf =
+  forM_ (Map.toList $ L.concretes lpgf) $ \(cid,concr) ->
+    writeFile' (path </> showCId cid <.> "lpgf.txt") (L.render $ L.pp concr)
+
+-- | Dump LPGF to file
+dumpLPGF :: FilePath -> LPGF -> IO ()
+dumpLPGF path lpgf =
+  forM_ (Map.toList $ L.concretes lpgf) $ \(cid,concr) -> do
+    let body = unlines $ map show (Map.toList $ L.lins concr)
+    writeFile' (path </> showCId cid <.> "lpgf.dump") body
+
+-- | Write a file and report it to console
+writeFile' :: FilePath -> String -> IO ()
+writeFile' p b = do
+  writeFile p b
+  putStrLn $ "Wrote " ++ p

src/compiler/GF/Compile/Optimize.hs

@@ -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
 

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -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",
+          extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
-                                 "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 ++ [
+ ] ++ imports ++ [
-  "import PGF hiding (Tree)",
+  "",
   "----------------------------------------------------",
   "-- 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,6 +135,7 @@ 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
@@ -203,11 +208,12 @@ prCompos gId lexical (_,catrules) =
     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,
@@ -219,7 +225,7 @@ hInstance gId _ m (cat,[]) = unlines [
 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")]
@@ -233,12 +239,15 @@ 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] ++ "]"
+       "[" ++ 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",_) = "" ---
@@ -257,15 +266,16 @@ 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..]]
+       where
-	     mkRHS f vars 
+         xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
-		 | isList =
+         mkRHS f vars
-		     if "Base" `isPrefixOf` f 
+           | isList =
-                       then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+               if "Base" `isPrefixOf` f
-		       else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
+                             then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
-		 | otherwise = 
+                 else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
-		     gId f +++  
+           | otherwise =
-		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
+               gId f +++
+               prTList " " [prParenth ("fg" +++ x) | x <- vars]
 
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
@@ -274,7 +284,7 @@ hSkeleton 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))
@@ -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
+        && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
-    where c = elemCat cat
+    where
-	  fs = map fst rules
+      c = elemCat cat
+      fs = map fst rules
 
 -- | Gets the element category of a list category.
 elemCat :: OIdent -> OIdent
@@ -337,4 +348,3 @@ composClass =
      "",
      "newtype C b a = C { unC :: b }"
     ]
-

src/compiler/GF/Compile/Rename.hs

@@ -23,9 +23,9 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.Rename (
-	       renameSourceTerm,
+     renameSourceTerm,
-	       renameModule
+     renameModule
-	      ) where
+    ) 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
@@ -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

src/compiler/GF/Compile/TypeCheck/Abstract.hs

@@ -13,11 +13,11 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
-		  checkContext,
+    checkContext,
-		  checkTyp,
+    checkTyp,
-		  checkDef,
+    checkDef,
-		  checkConstrs,
+    checkConstrs,
-		 ) where
+   ) where
 
 import GF.Data.Operations
 

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
@@ -116,7 +127,11 @@ inferLType gr g trm = case trm of
                       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)
+           _ ->
+             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 $$
+       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
-                                 text " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
+                                 " 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
@@ -153,7 +168,7 @@ inferLType gr g trm = case trm of
    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)
+       [] -> 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'
@@ -187,7 +202,7 @@ inferLType gr g trm = case trm of
 
 ---- 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
@@ -208,19 +223,25 @@ inferLType gr g trm = case trm of
      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)
+       _ | rT' == typeType && sT' == typeType -> do
-       _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
+         return (trm', typeType)
+       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
 
    Sort _     ->
      termWith trm $ return typeType
@@ -252,7 +273,7 @@ inferLType gr g trm = case trm of
      ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
      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,8 +330,21 @@ 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
@@ -329,25 +362,26 @@ 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 $$
+         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
-                      text "for" $$
+                      "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 $$
+         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
-                      text "for" $$
+                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
+                      "for argument list" $$
                       nest 2 stysError $$
-                      text "among" $$
+                      "among alternatives" $$
-                      nest 2 (vcat stypsError) $$
+                      nest 2 (vcat stypsError)
-                      maybe empty (\x -> text "with value type" <+> ppType x) mt
+
 
        (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
@@ -355,16 +389,22 @@ getOverload gr g mt ot = case appForm ot of
 -----             "resolved by excluding partial applications:" ++++
 -----             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
 
-
+--- now forgiving ambiguity with a warning AR 1/2/2014
-         _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
+--  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
-                           text "for" <+> hsep (map ppType tys) $$ 
+--  But it also gives a chance to ambiguous overloadings that were banned before.
-                           text "with alternatives" $$
+         (nps1,nps2) -> do
-                           nest 2 (vcat [ppType ty | (_,ty,_) <- if null vfs1 then vfs2 else vfs2])
+              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
@@ -385,7 +425,6 @@ 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
@@ -395,10 +434,12 @@ checkLType gr g trm typ0 = 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')
+          return $ (Abs bt x c', Prod bt' z a b')
-        _ -> checkError $ text "function type expected instead of" <+> ppType typ
+        _ -> 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,7 +464,7 @@ 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)
+      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
     T _ cs -> case typ of
       Table arg val -> do
         case allParamValues gr arg of
@@ -426,12 +473,12 @@ checkLType gr g trm typ0 = do
             ps <- testOvershadow ps0 vs
             if null ps
               then return ()
-              else checkWarn (text "patterns never reached:" $$
+              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
+           RecType _ -> termWith trm' $ return typeType
-           ExtR (Vr _) (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
+         ll2 <- case s of
-           RecType rr1 -> do
+           R ss -> return $ map fst ss
-                let (rr0,rr2) = recParts rr rr1
+           _ -> do
-                r2 <- justCheck g r' rr0
+             (s',typ2) <- inferLType gr g s
-                s2 <- justCheck g s' rr2
+             case typ2 of
-                return $ (ExtR r2 s2, typ) 
+               RecType ss -> return $ map fst ss
-           _ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$
+               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
-                            text "but found" <+> ppTerm Unqualified 0 ty)
+         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
-
+-}
    checkM rms (l,ty) = case lookup l rms of
      Just (Just ty0,t) -> do
        checkEqLType gr g ty ty0 t
@@ -538,9 +589,9 @@ checkLType gr g trm typ0 = do
      _ -> 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 <> 
+                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
-                      text "; try wrapping it with lin" <+> text cat
+                      "; try wrapping it with lin" <+> cat
-              else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms)
+              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'
@@ -578,9 +629,9 @@ pattContext env g typ p = case p of
     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" <+>
+      ("incompatible bindings of" <+>
-       fsep (map ppIdent pts) <+> 
+       fsep pts <+>
-       text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null 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
@@ -594,7 +645,7 @@ pattContext env g typ p = case p of
    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 $$
+    False ->
-                          text "expected:" <+> ppType t $$
+      let inferredType = ppTerm Qualified 0 u
-                          text "inferred:" <+> ppType 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,13 +690,13 @@ 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
 
@@ -635,12 +708,13 @@ checkIfEqLType gr g t u trm = do
 
      -- record subtyping
      (RecType rs, RecType ts) -> all (\ (l,a) ->
-                                   any (\ (k,b) -> alpha g a b && l == k) ts) rs
+                                   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
 
@@ -655,7 +729,8 @@ checkIfEqLType gr g t u trm = do
      (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
      --- the following should be one-way coercions only. AR 4/1/2001
@@ -670,7 +745,7 @@ checkIfEqLType gr g t u trm = do
                    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
@@ -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
--}

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
@@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
   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
@@ -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
+                          -- Left i     -> let (v,_) = reverse scope !! i
-                                        in tcError ("Variable" <+> pp v <+> "has escaped")
+                          --               in tcError ("Variable" <+> pp v <+> "has escaped")
-                          Right ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
+                                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'))
@@ -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 Rho   = Value -- No top-level ForAll
-type Tau   = Value	-- No ForAlls anywhere
+type Tau   = Value -- No ForAlls anywhere
 
 data MetaValue
   = Unbound Scope Sigma
@@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do
     go (Vr tv)    acc = acc
     go (App x y)  acc = go x (go y acc)
     go (Meta i)   acc
-	  | i `elem` acc  = acc
+      | i `elem` acc  = acc
-	  | otherwise	  = i : acc
+      | otherwise     = i : acc
     go (Q _)      acc = acc
     go (QC _)     acc = acc
     go (Sort _)   acc = acc
@@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do
   return (foldr (go []) [] tys)
   where
     go bound (Vr tv)            acc
-	  | tv `elem` bound             = acc
+      | tv `elem` bound             = acc
-	  | tv `elem` acc               = acc
+      | tv `elem` acc               = acc
-	  | otherwise                   = tv : 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,9 +765,9 @@ zonkTerm (Meta i) = do
 zonkTerm t = composOp zonkTerm t
 
 tc_value2term loc xs v =
-  case value2term loc xs v of
+  return $ value2term loc xs v
-    Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
+    -- Old value2term error message:
-    Right t -> return t
+    -- Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
 
 
 

src/compiler/GF/Compile/TypeCheck/RConcrete.hs

@@ -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

src/compiler/GF/Compile/TypeCheck/TC.hs

@@ -12,14 +12,15 @@
 -- Thierry Coquand's type checking algorithm that creates a trace
 -----------------------------------------------------------------------------
 
-module GF.Compile.TypeCheck.TC (AExp(..),
+module GF.Compile.TypeCheck.TC (
-	   Theory,
+    AExp(..),
-	   checkExp,
+    Theory,
-	   inferExp,
+    checkExp,
-	   checkBranch,
+    inferExp,
-	   eqVal,
+    checkBranch,
-	   whnf
+    eqVal,
-	  ) where
+    whnf
+  ) where
 
 import GF.Data.Operations
 import GF.Grammar
@@ -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 ---
+                           a' <- whnf $ VClos env a ---
-	(t',cs) <- checkExp th 
+                           (t',cs) <- checkExp th
-                           (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+                                          (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
-	return (AAbs x a' t', cs)
+                           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
@@ -205,8 +206,8 @@ inferExp th tenv@(k,rho,gamma) e = case e of
     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
+        b' <- whnf $ VClos ((x,VClos rho t):env) b
-	return $ (AApp f' a' b', b', csf ++ csa)
+        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))
 
@@ -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
@@ -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
+           b' <- whnf $ VClos ((x,VClos rho t):env) b
-	   return $ (AApp f' a' b', b', csf ++ csa)
+           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)
-

src/compiler/GF/Compile/Update.hs

@@ -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
+          Ok k  -> go (Map.insert c k map) is
-		     Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+          Bad _ -> fail $ render ("conflicting information in module"<+>m $$
-		                             nest 4 (ppJudgement Qualified (c,i)) $$
+                                  nest 4 (ppJudgement Qualified (c,i)) $$
-		                             "and" $+$
+                                  "and" $+$
-		                             nest 4 (ppJudgement Qualified (c,j)))
+                                  nest 4 (ppJudgement Qualified (c,j)))
         Nothing -> go (Map.insert c j map) is
 
 extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -147,18 +147,18 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
       | 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
+                                     Ok k  -> return $ Map.insert c k new
-		                     Bad _ -> do (base,j) <- case j of 
+                                     Bad _ -> do (base,j) <- case j of
-		                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
+                                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
-		                                               _          -> return (base,j)
+                                                               _          -> return (base,j)
-		                                 (name,i) <- case i of 
+                                                 (name,i) <- case i of
                                                                AnyInd _ m -> lookupOrigInfo gr (m,c)
                                                                _          -> return (name,i)
-		                                 checkError ("cannot unify the information" $$ 
+                                                 checkError ("cannot unify the information" $$
-		                                             nest 4 (ppJudgement Qualified (c,i)) $$
+                                                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                                             "in module" <+> name <+> "with" $$
+                                                             "in module" <+> name <+> "with" $$
-		                                             nest 4 (ppJudgement Qualified (c,j)) $$
+                                                             nest 4 (ppJudgement Qualified (c,j)) $$
-		                                             "in module" <+> base)
+                                                             "in module" <+> base)
                          Nothing-> if isCompl
                                      then return $ Map.insert c (indirInfo name i) new
                                      else return $ Map.insert c i new

src/compiler/GF/Compiler.hs

@@ -1,9 +1,11 @@
-module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writePGF, writeLPGF, writeOutputs) where
 
 import PGF
 import PGF.Internal(concretes,optimizePGF,unionPGF)
 import PGF.Internal(putSplitAbs,encodeFile,runPut)
-import GF.Compile as S(batchCompile,link,srcAbsName)
+import LPGF(LPGF)
+import qualified LPGF.Internal as LPGF
+import GF.Compile as S(batchCompile,link,linkl,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
 import GF.Compile.ConcreteToHaskell(concretes2haskell)
@@ -11,7 +13,8 @@ import GF.Compile.GrammarToCanonical--(concretes2canonical)
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
-import GF.Grammar.CFG
+import GF.Grammar.CFG hiding (Grammar)
+import GF.Grammar.Grammar (Grammar, ModuleName)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
@@ -23,10 +26,11 @@ import GF.Text.Pretty(render,render80)
 import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Time(UTCTime)
 import qualified Data.ByteString.Lazy as BSL
 import GF.Grammar.CanonicalJSON (encodeJSON)
 import System.FilePath
-import Control.Monad(when,unless,forM_)
+import Control.Monad(when,unless,forM,void)
 
 -- | Compile the given GF grammar files. The result is a number of @.gfo@ files
 -- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
@@ -93,6 +97,10 @@ compileSourceFiles opts fs =
 -- If a @.pgf@ file by the same name already exists and it is newer than the
 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
 -- recreated. Calls 'writePGF' and 'writeOutputs'.
+linkGrammars :: Options -> (UTCTime,[(ModuleName, Grammar)]) -> IOE ()
+linkGrammars opts (_,cnc_grs) | FmtLPGF `elem` flag optOutputFormats opts = do
+  lpgf <- linkl opts (head cnc_grs)
+  void $ writeLPGF opts lpgf
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -145,7 +153,7 @@ unionPGFFiles opts fs =
              pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
          if pgfFile `elem` fs
            then putStrLnE $ "Refusing to overwrite " ++ pgfFile
-           else writePGF opts pgf
+           else void $ writePGF opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -162,26 +170,39 @@ writeOutputs opts pgf = do
 -- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
 -- 'link') to a @.pgf@ file.
 -- A split PGF file is output if the @-split-pgf@ option is used.
-writePGF :: Options -> PGF -> IOE ()
+writePGF :: Options -> PGF -> IOE [FilePath]
 writePGF opts pgf =
     if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
   where
     writeNormalPGF =
        do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
           writing opts outfile $ encodeFile outfile pgf
+          return [outfile]
 
     writeSplitPGF =
       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
          writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
                                 --encodeFile_ outfile (putSplitAbs pgf)
-         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
+         outfiles <- forM (Map.toList (concretes pgf)) $ \cnc -> do
            let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
            writing opts outfile $ encodeFile outfile cnc
+           return outfile
 
+         return (outfile:outfiles)
 
-writeOutput :: Options -> FilePath-> String -> IOE ()
+writeLPGF :: Options -> LPGF -> IOE FilePath
-writeOutput opts file str = writing opts path $ writeUTF8File path str
+writeLPGF opts lpgf = do
-  where path = outputPath opts file
+  let
+    grammarName = fromMaybe (showCId (LPGF.absname lpgf)) (flag optName opts)
+    outfile = outputPath opts (grammarName <.> "lpgf")
+  writing opts outfile $ liftIO $ LPGF.encodeFile outfile lpgf
+  return outfile
+
+writeOutput :: Options -> FilePath-> String -> IOE FilePath
+writeOutput opts file str = do
+  let outfile = outputPath opts file
+  writing opts outfile $ writeUTF8File outfile str
+  return outfile
 
 -- * Useful helper functions
 

src/compiler/GF/Data/BacktrackM.hs

@@ -16,18 +16,18 @@
 {-# LANGUAGE CPP #-}
 module GF.Data.BacktrackM (
                     -- * the backtracking state monad
-		    BacktrackM,
+                    BacktrackM,
-		    -- * monad specific utilities
+                    -- * monad specific utilities
-		    member,
+                    member,
-		    cut,
+                    cut,
-		    -- * running the monad
+                    -- * running the monad
-		    foldBM,          runBM,
+                    foldBM,          runBM,
-		    foldSolutions,   solutions,
+                    foldSolutions,   solutions,
-		    foldFinalStates, finalStates,
+                    foldFinalStates, finalStates,
 
-		    -- * reexport the 'MonadState' class
+                    -- * reexport the 'MonadState' class
-		    module Control.Monad.State.Class,
+                    module Control.Monad.State.Class,
-		  ) where
+                  ) 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

src/compiler/GF/Data/Graph.hs

@@ -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)
@@ -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]

src/compiler/GF/Data/Graphviz.hs

@@ -13,14 +13,14 @@
 -----------------------------------------------------------------------------
 
 module GF.Data.Graphviz (
-				  Graph(..), GraphType(..), 
+                          Graph(..), GraphType(..),
-				  Node(..), Edge(..),
+                          Node(..), Edge(..),
-				  Attr,
+                          Attr,
-                                  addSubGraphs,
+                          addSubGraphs,
-                                  setName,
+                          setName,
-                                  setAttr,
+                          setAttr,
-				  prGraphviz
+                          prGraphviz
-			) where
+                        ) where
 
 import Data.Char
 
@@ -76,8 +76,8 @@ prSubGraph g@(Graph _ i _ _ _ _) =
 prGraph :: Graph -> String
 prGraph (Graph t id at ns es ss) =
     unlines $ map (++";") (map prAttr at
-		           ++ map prNode ns 
+                           ++ map prNode ns
-		           ++ map (prEdge t) es
+                           ++ 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

src/compiler/GF/Data/IntMapBuilder.hs

@@ -0,0 +1,61 @@
+-- | In order to build an IntMap in one pass, we need a map data structure with
+-- fast lookup in both keys and values.
+-- This is achieved by keeping a separate reversed map of values to keys during building.
+module GF.Data.IntMapBuilder where
+
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import Data.Hashable (Hashable)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Tuple (swap)
+import Prelude hiding (lookup)
+
+data IMB a = IMB {
+  intMap :: IntMap a,
+  valMap :: HashMap a Int
+}
+
+-- | An empty IMB
+empty :: (Eq a, Hashable a) => IMB a
+empty = IMB {
+  intMap = IntMap.empty,
+  valMap = HashMap.empty
+}
+
+-- | An empty IntMap
+emptyIntMap :: IntMap a
+emptyIntMap = IntMap.empty
+
+-- | Lookup a value
+lookup :: (Eq a, Hashable a) => a -> IMB a -> Maybe Int
+lookup a IMB { valMap = vm } = HashMap.lookup a vm
+
+-- | Insert without any lookup
+insert :: (Eq a, Hashable a) => a -> IMB a -> (Int, IMB a)
+insert a IMB { intMap = im, valMap = vm } =
+  let
+    ix = IntMap.size im
+    im' = IntMap.insert ix a im
+    vm' = HashMap.insert a ix vm
+    imb' = IMB { intMap = im', valMap = vm' }
+  in
+    (ix, imb')
+
+-- | Insert only when lookup fails
+insert' :: (Eq a, Hashable a) => a -> IMB a -> (Int, IMB a)
+insert' a imb =
+  case lookup a imb of
+    Just ix -> (ix, imb)
+    Nothing -> insert a imb
+
+-- | Build IMB from existing IntMap
+fromIntMap :: (Eq a, Hashable a) => IntMap a -> IMB a
+fromIntMap im = IMB {
+  intMap = im,
+  valMap = HashMap.fromList (map swap (IntMap.toList im))
+}
+
+-- | Get IntMap from IMB
+toIntMap :: (Eq a, Hashable a) => IMB a -> IntMap a
+toIntMap = intMap

src/compiler/GF/Data/Operations.hs

@@ -15,34 +15,34 @@
 -----------------------------------------------------------------------------
 
 module GF.Data.Operations (
-		   -- ** The Error monad
+     -- ** The Error monad
-		   Err(..), err, maybeErr, testErr, fromErr, errIn, 
+     Err(..), err, maybeErr, testErr, fromErr, errIn,
-		   lookupErr,
+     lookupErr,
 
-		   -- ** Error monad class
+     -- ** Error monad class
-		   ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
+     ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
-                   liftErr,
+                 liftErr,
 
-		   -- ** Checking
+     -- ** Checking
-		   checkUnique, unifyMaybeBy, unifyMaybe,
+     checkUnique, unifyMaybeBy, unifyMaybe,
 
-           -- ** Monadic operations on lists and pairs
+         -- ** Monadic operations on lists and pairs
-		   mapPairsM, pairM,
+     mapPairsM, pairM,
 
-		   -- ** Printing
+     -- ** Printing
-		   indent, (+++), (++-), (++++), (+++-), (+++++),
+     indent, (+++), (++-), (++++), (+++-), (+++++),
-		   prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, 
+     prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
-		   prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+     prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
-		   numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+     numberedParagraphs, prConjList, prIfEmpty, wrapLines,
 
-		   -- ** Topological sorting
+     -- ** Topological sorting
-		   topoTest, topoTest2,
+     topoTest, topoTest2,
 
-		   -- ** Misc
+     -- ** Misc
-		   readIntArg,
+     readIntArg,
-		   iterFix,  chunks,
+     iterFix,  chunks,
 
-		  ) where
+    ) where
 
 import Data.Char (isSpace, toUpper, isSpace, isDigit)
 import Data.List (nub, partition, (\\))
@@ -204,7 +204,7 @@ 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)

src/compiler/GF/Data/Relation.hs

@@ -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'
@@ -117,8 +117,8 @@ 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
+          where ys = allRelated r x
-                 zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+                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,

src/compiler/GF/Data/Utilities.hs

@@ -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 [a] = a
-	  fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+          fm abs = let (as, bs) = split abs in fm as `merge` fm bs
 
 select :: [a] -> [(a, [a])]
 select [] = []

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
@@ -30,7 +31,7 @@ data TypeApp  = TypeApp CatId [Type]        deriving Show
 data TypeBinding = TypeBinding VarId Type   deriving Show
 
 --------------------------------------------------------------------------------
--- ** Concreate syntax
+-- ** Concrete syntax
 
 -- | Concrete Syntax
 data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
@@ -102,9 +103,9 @@ data TableRow  rhs = TableRow  LinPattern rhs
 
 -- *** Identifiers in Concrete Syntax
 
-newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
+newtype PredefId   = PredefId Id        deriving (Eq,Ord,Show)
-newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
+newtype LabelId    = LabelId Id         deriving (Eq,Ord,Show)
-data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
+newtype VarValueId = VarValueId QualId  deriving (Eq,Ord,Show)
 
 -- | Name of param type or param value
 newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
@@ -115,9 +116,9 @@ newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 newtype ModId = ModId Id  deriving (Eq,Ord,Show)
 
 newtype CatId = CatId Id  deriving (Eq,Ord,Show)
-newtype FunId = FunId Id  deriving (Eq,Show)
+newtype FunId = FunId Id  deriving (Eq,Ord,Show)
 
-data VarId = Anonymous | VarId Id  deriving Show
+data VarId = Anonymous | VarId Id  deriving (Eq,Show)
 
 newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
 type FlagName = Id
@@ -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)
 
 --------------------------------------------------------------------------------
@@ -265,7 +266,6 @@ instance PPA LinPattern where
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
       WildPattern     -> pp "_"
-      _ -> parens p
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="
 

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 ()
@@ -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)]
@@ -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:

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 }

src/compiler/GF/Grammar/Lookup.hs

@@ -30,7 +30,7 @@ module GF.Grammar.Lookup (
            lookupFunType,
            lookupCatContext,
            allOpers, allOpersTo
-	      ) where
+          ) where
 
 import GF.Data.Operations
 import GF.Infra.Ident

src/compiler/GF/Grammar/Macros.hs

@@ -590,7 +590,7 @@ 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

src/compiler/GF/Grammar/PatternMatch.hs

@@ -12,11 +12,12 @@
 -- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
 -----------------------------------------------------------------------------
 
-module GF.Grammar.PatternMatch (matchPattern,
+module GF.Grammar.PatternMatch (
-		     testOvershadow, 
+                                matchPattern,
-		     findMatch,
+                                testOvershadow,
-                     measurePatt
+                                findMatch,
-		    ) where
+                                measurePatt
+                               ) where
 
 import GF.Data.Operations
 import GF.Grammar.Grammar

src/compiler/GF/Grammar/Printer.hs

@@ -175,18 +175,18 @@ 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))) $$
+                                       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))) $$
+                                 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))) $$
+                                 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))) $$
+                                 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)
@@ -198,14 +198,14 @@ ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e
 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
+                                                   TRaw     -> y
-			                           TTyped t -> Typed y t
+                                                   TTyped t -> Typed y t
-			                           TComp  t -> Typed y t
+                                                   TComp  t -> Typed y t
-			                           TWild  t -> Typed y t
+                                                   TWild  t -> Typed y t
-			                 in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
+                                         in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
-			                    nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                            nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
-			                   '}'
+                                           '}'
-			   _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
+                           _          -> 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)))])
@@ -362,4 +362,3 @@ getLet :: Term -> ([LocalDef], Term)
 getLet (Let l e) = let (ls,e') = getLet e
                    in (l:ls,e')
 getLet e         = ([],e)
-

src/compiler/GF/Grammar/Values.hs

@@ -12,15 +12,16 @@
 -- (Description of the module)
 -----------------------------------------------------------------------------
 
-module GF.Grammar.Values (-- ** Values used in TC type checking
+module GF.Grammar.Values (
-	       Val(..), Env,
+               -- ** Values used in TC type checking
-	       -- ** Annotated tree used in editing
+               Val(..), Env,
+               -- ** Annotated tree used in editing
                Binds, Constraints, MetaSubst,
-	       -- ** For TC
+               -- ** For TC
-	       valAbsInt, valAbsFloat, valAbsString, vType,
+               valAbsInt, valAbsFloat, valAbsString, vType,
-	       isPredefCat,
+               isPredefCat,
-	       eType, 
+               eType,
-	      ) where
+              ) where
 
 import GF.Infra.Ident
 import GF.Grammar.Grammar

src/compiler/GF/Infra/CheckM.hs

@@ -14,10 +14,10 @@
 
 module GF.Infra.CheckM
           (Check, CheckResult, Message, runCheck, runCheck',
-	   checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
+           checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
-	   checkIn, checkInModule, checkMap, checkMapRecover,
+           checkIn, checkInModule, checkMap, checkMapRecover,
            parallelCheck, accumulateError, commitCheck,
-	  ) where
+          ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Data.Operations

src/compiler/GF/Infra/Ident.hs

@@ -13,18 +13,18 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- ** Identifiers
-              ModuleName(..), moduleNameS,
+  ModuleName(..), moduleNameS,
-	      Ident, ident2utf8, showIdent, prefixIdent,
+  Ident, ident2utf8, showIdent, prefixIdent,
-              -- *** Normal identifiers (returned by the parser)
+  -- *** Normal identifiers (returned by the parser)
-	      identS, identC, identW,
+  identS, identC, identW,
-              -- *** Special identifiers for internal use
+  -- *** Special identifiers for internal use
-              identV, identA, identAV,
+  identV, identA, identAV,
-	      argIdent, isArgIdent, getArgIndex,
+  argIdent, isArgIdent, getArgIndex,
-              varStr, varX, isWildIdent, varIndex,
+  varStr, varX, isWildIdent, varIndex,
-              -- *** Raw identifiers
+  -- *** Raw identifiers
-              RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-              isPrefixOf, showRawIdent
+  isPrefixOf, showRawIdent
-	     ) where
+) where
 
 import qualified Data.ByteString.UTF8 as UTF8
 import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -77,7 +77,6 @@ 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
 

src/compiler/GF/Infra/Option.hs

@@ -87,7 +87,8 @@ data Verbosity = Quiet | Normal | Verbose | Debug
 data Phase = Preproc | Convert | Compile | Link
   deriving (Show,Eq,Ord)
 
-data OutputFormat = FmtPGFPretty
+data OutputFormat = FmtLPGF
+                  | FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
                   | FmtJavaScript
@@ -131,8 +132,13 @@ data CFGTransform = CFGNoLR
                   | CFGRemoveCycles
   deriving (Show,Eq,Ord)
 
-data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
+data HaskellOption = HaskellNoPrefix
-                   | HaskellConcrete | HaskellVariants | HaskellData
+                   | HaskellGADT
+                   | HaskellLexical
+                   | HaskellConcrete
+                   | HaskellVariants
+                   | HaskellData
+                   | HaskellPGF2
   deriving (Show,Eq,Ord)
 
 data Warning = WarnMissingLincat
@@ -330,7 +336,7 @@ optDescr =
      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,
+                  "Multiple concrete: pgf (default), lpgf, 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")
@@ -472,7 +478,8 @@ outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
 outputFormatsExpl =
-    [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
+    [(("lpgf",         FmtLPGF),"Linearisation-only PGF"),
+     (("pgf_pretty",   FmtPGFPretty),"Human-readable PGF"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
      (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
      (("js",           FmtJavaScript),"JavaScript (whole grammar)"),
@@ -532,7 +539,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

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

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
 
 {-
@@ -436,7 +437,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

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

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" ""

src/compiler/GF/Speech/FiniteState.hs

@@ -12,15 +12,15 @@
 -- A simple finite state network module.
 -----------------------------------------------------------------------------
 module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
-			      startState, finalStates,
+                              startState, finalStates,
-			      states, transitions,
+                              states, transitions,
                               isInternal,
-			      newFA, newFA_,
+                              newFA, newFA_,
-			      addFinalState,
+                              addFinalState,
-			      newState, newStates,
+                              newState, newStates,
                               newTransition, newTransitions,
                               insertTransitionWith, insertTransitionsWith,
-			      mapStates, mapTransitions,
+                              mapStates, mapTransitions,
                               modifyTransitions,
                               nonLoopTransitionsTo, nonLoopTransitionsFrom,
                               loops,
@@ -28,11 +28,11 @@ module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
                               oneFinalState,
                               insertNFA,
                               onGraph,
-			      moveLabelsToNodes, removeTrivialEmptyNodes,
+                              moveLabelsToNodes, removeTrivialEmptyNodes,
                               minimize,
                               dfa2nfa,
                               unusedNames, renameStates,
-			      prFAGraphviz, faToGraphviz) where
+                              prFAGraphviz, faToGraphviz) where
 
 import Data.List
 import Data.Maybe
@@ -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
 
@@ -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)]
+         where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
-		  (c',is') = mapAccumL fixIncoming c is
+               (c',is') = mapAccumL fixIncoming c is
-		  (ns,ess) = unzip (concat is')
+               (ns,ess) = unzip (concat is')
 
 
 -- | Remove empty nodes which are not start or final, and have
@@ -234,17 +234,17 @@ fixIncoming :: (Ord n, Eq a) => [n]
                                                       -- incoming edges.
 fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
   where ls = nub $ map edgeLabel es
-	(cs',cs'') = splitAt (length ls) cs
+        (cs',cs'') = splitAt (length ls) cs
-	newNodes = zip cs' ls
+        newNodes = zip cs' ls
-	es' = [ (x,n,()) | x <- map fst newNodes ]
+        es' = [ (x,n,()) | x <- map fst newNodes ]
-	-- separate cyclic and non-cyclic edges
+        -- separate cyclic and non-cyclic edges
-	(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
+        (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-	          -- keep all incoming non-cyclic edges with the right label
+                  -- keep all incoming non-cyclic edges with the right label
-	to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
+        to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-	          -- for each cyclic edge with the right label, 
+                  -- for each cyclic edge with the right label,
-	          -- add an edge from each of the new nodes (including this one)
+                  -- add an edge from each of the new nodes (including this one)
-		    ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
+                  ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
-	newContexts = [ (v, to v) | v <- newNodes ]
+        newContexts = [ (v, to v) | v <- newNodes ]
 
 --alphabet :: Eq b => Graph n a (Maybe b) -> [b]
 --alphabet = nub . catMaybes . map edgeLabel . edges
@@ -254,18 +254,18 @@ 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
+        h currentStates oldStates es
-	    | Set.null currentStates = (oldStates,es)
+            | Set.null currentStates = (oldStates,es)
-	    | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
+            | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
-	    where 
+            where
-	    allOldStates = oldStates `Set.union` currentStates
+            allOldStates = oldStates `Set.union` currentStates
             (newStates,es') = new (Set.toList currentStates) Set.empty es
-	    uniqueNewStates = newStates Set.\\ allOldStates
+            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)
@@ -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'',s') = newNode () g'
-	  g''' = newEdges [(s',f,Nothing) | f <- fs] g''
+          g''' = newEdges [(s',f,Nothing) | f <- fs] g''
 
 dfa2nfa :: DFA a -> NFA a
 dfa2nfa = mapTransitions Just
@@ -316,10 +316,10 @@ faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
 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)]
+          where attrs = [("label",l)]
-			   ++ if n == s then [("shape","box")] else []
+                 ++ if n == s then [("shape","box")] else []
-			   ++ if n `elem` f then [("style","bold")] else []
+                 ++ if n `elem` f then [("style","bold")] else []
-	 mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
+         mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
 
 --
 -- * Utilities

src/compiler/GF/Speech/GSL.hs

@@ -32,7 +32,7 @@ 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 ("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)

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)
@@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
 
 ($++$) :: Doc -> Doc -> Doc
 x $++$ y = x $$ emptyLine $$ y
-

src/compiler/GF/Speech/SRG.hs

@@ -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
+               , srgStartCat :: Cat     -- ^ start category name
-                 , srgExternalCats :: Set Cat
+               , srgExternalCats :: Set Cat
-                 , srgLanguage :: Maybe String -- ^ The language for which the grammar 
+               , srgLanguage :: Maybe String -- ^ The language for which the grammar
-                                                   --   is intended, e.g. en-UK
+                                             --   is intended, e.g. en-UK
-	         , srgRules :: [SRGRule] 
+               , srgRules :: [SRGRule]
-	       }
+               }
-	 deriving (Eq,Show)
+        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
 
@@ -111,10 +111,10 @@ 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),

src/compiler/GF/Speech/SRGS_ABNF.hs

@@ -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
 
@@ -125,4 +125,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
 
 ($++$) :: Doc -> Doc -> Doc
 x $++$ y = x $$ emptyLine $$ y
-

src/compiler/GF/Speech/SRGS_XML.hs

@@ -37,7 +37,7 @@ prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
               [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)]
@@ -81,12 +81,12 @@ oneOf = Tag "one-of" []
 grammar :: Maybe SISRFormat
         -> String  -- ^ root
         -> Maybe String -- ^language
-	-> [XML] -> XML
+        -> [XML] -> XML
 grammar sisr root ml =
     Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
-		     ("version","1.0"),
+                     ("version","1.0"),
-		     ("mode","voice"),
+                     ("mode","voice"),
-		     ("root",root)]
+                     ("root",root)]
                  ++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
                  ++ maybe [] (\l -> [("xml:lang", l)]) ml
 

src/compiler/GF/Text/Transliterations.hs

@@ -142,7 +142,7 @@ transUrdu =
   (mkTransliteration "Urdu" allTrans allCodes) where
     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
@@ -156,7 +156,7 @@ transSindhi =
     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
@@ -300,32 +300,30 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
 
 transAmharic :: Transliteration
 transAmharic = mkTransliteration "Amharic" allTrans allCodes where
- 
+  allTrans = words $
-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*  "++
-  	" h.  h-  h'  h(  h)  h  h?  h*  l.  l-  l'  l(  l)  l  l?  l*  "++
+    " s.  s-  s'  s(  s)  s  s?  s*  r.  r-  r'  r(  r)  r  r?  r* "++
-	" H.  H-  H'  H(  H)  H  H?  H*  m.  m-  m'  m(  m)  m  m?  m*  "++
+    " -   -   -   -   -  -   -  -   x.  x-  x'  x(  x)  x  x?   x* "++
-	" s.  s-  s'  s(  s)  s  s?  s*  r.  r-  r'  r(  r)  r  r?  r* "++
+    " q.  q-  q'  q(  q)  q  q?  q*  -   -   -   -   -   -  -   - "++
-	" -   -   -   -   -  -   -  -   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* "++
-	" b.  b-  b'  b(  b)  b  b?  b*  v.  v-  v'  v(  v)  v  v?  v* "++
+    " X.  X-  X'  X(  X)  X  X?  -   -   -   -   X*  -   -  -   - "++
-	" t.  t-  t'  t(  t)  t  t?  t*  c.  c-  c'  c(  c)  c  c?  c* "++
+    " n.  n-  n'  n(  n)  n  n?  n*  N.  N-  N'  N(  N)  N  N?  N* "++
-	" X.  X-  X'  X(  X)  X  X?  -   -   -   -   X*  -   -  -   - "++
+    " a   u   i   A   E   e  o   e*  k.  k-  k'  k(  k)  k  k?  - "++
-	" n.  n-  n'  n(  n)  n  n?  n*  N.  N-  N'  N(  N)  N  N?  N* "++
+    " -   -   -   k*  -   -  -   -   -   -   -   -   -   -  -   - "++
-	" a   u   i   A   E   e  o   e*  k.  k-  k'  k(  k)  k  k?  - "++
+    " -   -   -   -   -   -  -   -   w.  w-  w'  w(  w)  w  w?  w* "++
-	" -   -   -   k*  -   -  -   -   -   -   -   -   -   -  -   - "++
+    " -   -   -   -   -   -  -   -   z.  z-  z'  z(  z)  z  z?  z* "++
-	" -   -   -   -   -   -  -   -   w.  w-  w'  w(  w)  w  w?  w* "++
+    " Z.  Z-  Z'  Z(  Z)  Z  Z?  Z*  y.  y-  y'  y(  y)  y  y?  y* "++
-	" -   -   -   -   -   -  -   -   z.  z-  z'  z(  z)  z  z?  z* "++
+    " d.  d-  d'  d(  d)  d  d?  d*  -   -   -   -   -   -  -   - "++
-	" Z.  Z-  Z'  Z(  Z)  Z  Z?  Z*  y.  y-  y'  y(  y)  y  y?  y* "++
+    " j.  j-  j'  j(  j)  j  j?  j*  g.  g-  g'  g(  g)  g  g?  - "++
-	" d.  d-  d'  d(  d)  d  d?  d*  -   -   -   -   -   -  -   - "++
+    " -   -   -   g*  -   -  -   -   -   -   -   -   -   -  -   - "++
-	" j.  j-  j'  j(  j)  j  j?  j*  g.  g-  g'  g(  g)  g  g?  - "++
+    " T.  T-  T'  T(  T)  T  T?  T*  C.  C-  C'  C(  C)  C  C?  C* "++
-	" -   -   -   g*  -   -  -   -   -   -   -   -   -   -  -   - "++
+    " P.  P-  P'  P(  P)  P  P?  P*  S.  S-  S'  S(  S)  S  S?  S* "++
-	" T.  T-  T'  T(  T)  T  T?  T*  C.  C-  C'  C(  C)  C  C?  C* "++
+    " -   -   -   -   -   -  -   -   f.  f-  f'  f(  f)  f  f?  f*"++
-	" P.  P-  P'  P(  P)  P  P?  P*  S.  S-  S'  S(  S)  S  S?  S* "++
+    " p.  p-  p'  p(  p)  p  p?  p*"
-	" -   -   -   -   -   -  -   -   f.  f-  f'  f(  f)  f  f?  f*"++
+  allCodes = [0x1200..0x1357]
-	" p.  p-  p'  p(  p)  p  p?  p*" 	
-allCodes = [0x1200..0x1357]
 
 -- by Prasad 31/5/2013
 transSanskrit :: Transliteration

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 Fun where 
-instance JSON Param where showJSON (Param name rhs) = definition name rhs
+  showJSON (Fun   name typ) = signature  name typ
-instance JSON Oper  where showJSON (Oper  name rhs) = definition name rhs
+  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)

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],
+                           params:: [Param],
-		           lincats:: [Lincat],
+                           lincats:: [Lincat],
-		           opers:: [Oper],
+                           opers:: [Oper],
-		           lins:: [Lin] }
+                           lins:: [Lin] }
                 deriving Show
 
 data Param  = Param  {pname:: Id, prhs:: String}              deriving Show

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

src/runtime/c/install.sh

@@ -0,0 +1,3 @@
+bash setup.sh configure
+bash setup.sh build
+bash setup.sh install

src/runtime/haskell-bind/PGF2/Expr.hsc

@@ -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

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
+homepage: https://www.grammaticalframework.org/
-license: LGPL-3
+bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-license-file: LICENSE
 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,
+    base >= 4.9.1 && < 4.15,
-    containers,
+    containers >= 0.5.7 && < 0.7,
-    pretty
+    pretty >= 1.1.3 && < 1.2
   default-language: Haskell2010
   build-tools: hsc2hs
   extra-libraries: pgf gu

src/runtime/haskell-bind/stack-ghc7.10.3.yaml

@@ -0,0 +1,3 @@
+resolver: lts-6.35 # ghc 7.10.3
+
+allow-newer: true

src/runtime/haskell-bind/stack-ghc8.0.2.yaml

@@ -0,0 +1 @@
+resolver: lts-9.21 # ghc 8.0.2

src/runtime/haskell-bind/stack-ghc8.10.4.yaml

@@ -0,0 +1 @@
+resolver: lts-18.0 # ghc 8.10.4

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 #-}

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 -}
 
 ------------------------------------------------------------------------

src/runtime/haskell/LPGF.hs

@@ -0,0 +1,234 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Linearisation-only portable grammar format.
+--
+-- LPGF is an output format from the GF compiler, intended as a smaller and faster alternative to PGF.
+-- This API allows LPGF files to be used in Haskell programs.
+--
+-- The implementation closely follows description in Section 2 of Angelov, Bringert, Ranta (2009):
+-- "PGF: A Portable Run-Time Format for Type-Theoretical Grammars".
+-- http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.640.6330&rep=rep1&type=pdf
+module LPGF (
+  -- * LPGF
+  LPGF,
+  showLPGF,
+  readLPGF,
+
+  -- * Identifiers
+  CId,
+  mkCId,
+  showCId,
+  readCId,
+
+  -- * Abstract syntax
+  Abstract,
+  abstractName,
+
+  -- ** Categories
+
+  -- ** Functions
+
+  -- ** Expressions
+  Expr,
+  PGF.showExpr,
+  PGF.readExpr,
+
+  -- ** Types
+
+  -- ** Type checking
+
+  -- * Concrete syntax
+  Language,
+  PGF.showLanguage,
+  PGF.readLanguage,
+  languages,
+  Concrete,
+  LPGF.concretes,
+
+  -- ** Linearization
+  linearize,
+  linearizeText,
+  linearizeConcrete,
+  linearizeConcreteText
+) where
+
+import LPGF.Internal
+import PGF (Language)
+import PGF.CId
+import PGF.Expr (Expr, Literal (..))
+import PGF.Tree (Tree (..), expr2tree, prTree)
+import qualified PGF
+
+import Data.Binary (decodeFile)
+import Data.Either (isLeft)
+import qualified Data.IntMap as IntMap
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import Numeric (showFFloat)
+import Text.Printf (printf)
+
+import Prelude hiding ((!!))
+import qualified Prelude
+
+-- | The abstract language name is the name of the top-level abstract module.
+abstractName :: LPGF -> CId
+abstractName = absname
+
+-- | List of all languages available in the given grammar.
+languages :: LPGF -> [Language]
+languages = Map.keys . LPGF.Internal.concretes
+
+-- | Map of all languages and their corresponding concrete sytaxes.
+concretes :: LPGF -> Map.Map Language Concrete
+concretes = LPGF.Internal.concretes
+
+-- | Reads file in LPGF and produces 'LPGF' term.
+-- The file is usually produced with:
+--
+-- > $ gf --make --output-format=lpgf <grammar file name>
+readLPGF :: FilePath -> IO LPGF
+readLPGF = Data.Binary.decodeFile
+
+-- | Produce pretty-printed representation of an LPGF.
+showLPGF :: LPGF -> String
+showLPGF = render . pp
+
+-- | Main linearize function, to 'String'
+linearize :: LPGF -> Language -> Expr -> String
+linearize lpgf lang expr = T.unpack $ linearizeText lpgf lang expr
+
+-- | Main linearize function, to 'Data.Text.Text'
+linearizeText :: LPGF -> Language -> Expr -> Text
+linearizeText lpgf lang =
+  case Map.lookup lang (LPGF.Internal.concretes lpgf) of
+    Just concr -> linearizeConcreteText concr
+    Nothing -> error $ printf "Unknown language: %s" (showCId lang)
+
+-- | Language-specific linearize function, to 'String'
+linearizeConcrete :: Concrete -> Expr -> String
+linearizeConcrete concr expr = T.unpack $ linearizeConcreteText concr expr
+
+-- | Language-specific linearize function, to 'Data.Text.Text'
+linearizeConcreteText :: Concrete -> Expr -> Text
+linearizeConcreteText concr expr = lin2string $ lin (expr2tree expr)
+  where
+    lin :: Tree -> LinFun
+    lin = \case
+      Fun f as ->
+        case Map.lookup f (lins concr) of
+          Just t -> eval cxt t
+            where cxt = Context { cxToks = toks concr, cxArgs = map lin as }
+          _ -> Missing f
+      Lit l -> Tuple [Token (T.pack s)]
+        where
+          s = case l of
+            LStr s -> s
+            LInt i -> show i
+            LFlt f -> showFFloat (Just 6) f ""
+      x -> error $ printf "Cannot lin: %s" (prTree x)
+
+-- | Evaluation context
+data Context = Context {
+  cxArgs :: [LinFun], -- ^  is a sequence of terms
+  cxToks :: IntMap.IntMap Text -- ^ token map
+}
+
+-- | Operational semantics
+eval :: Context -> LinFun -> LinFun
+eval cxt t = case t of
+  Error err -> error err
+  Pre pts df -> Pre pts' df'
+    where
+      pts' = [(pfxs, eval cxt t) | (pfxs, t) <- pts]
+      df' = eval cxt df
+
+  Concat s t -> Concat v w
+    where
+      v = eval cxt s
+      w = eval cxt t
+  Tuple ts -> Tuple vs
+    where vs = map (eval cxt) ts
+  Projection t u ->
+    case (eval cxt t, eval cxt u) of
+      (Missing f, _) -> Missing f
+      (Tuple vs, Missing _) | not (null vs) -> vs !! 0 -- cannot know how deep to unpack; this gives best results with current testsuite
+      (_, Missing f) -> Missing f
+      (Tuple vs, Ix i) -> vs !! (i-1)
+      (t', tv@(Tuple _)) -> eval cxt $ foldl Projection t' (flattenTuple tv)
+      (t',u') -> error $ printf "Incompatible projection:\n- %s\n⇓ %s\n- %s\n⇓ %s" (show t) (show t') (show u) (show u')
+  Argument i -> cxArgs cxt !! (i-1)
+
+  PreIx pts df -> Pre pts' df'
+    where
+      pts' = [(pfxs, eval cxt t) | (ix, t) <- pts, let pfxs = maybe [] (read . T.unpack) $ IntMap.lookup ix (cxToks cxt)]
+      df' = eval cxt df
+  TokenIx i -> maybe Empty Token $ IntMap.lookup i (cxToks cxt)
+
+  _ -> t
+
+flattenTuple :: LinFun -> [LinFun]
+flattenTuple = \case
+  Tuple vs -> concatMap flattenTuple vs
+  lf -> [lf]
+
+-- | Turn concrete syntax terms into an actual string.
+-- This is done in two passes, first to flatten concats & evaluate pre's, then to
+-- apply BIND and other predefs.
+lin2string :: LinFun -> Text
+lin2string lf = T.unwords $ join $ flatten [lf]
+  where
+    -- Process bind et al into final token list
+    join :: [Either LinFun Text] -> [Text]
+    join elt = case elt of
+      Right tok:Left Bind:ls ->
+        case join ls of
+          next:ls' -> tok `T.append` next : ls'
+          _ -> []
+      Right tok:ls -> tok : join ls
+      Left Space:ls -> join ls
+      Left Capit:ls ->
+        case join ls of
+          next:ls' -> T.toUpper (T.take 1 next) `T.append` T.drop 1 next : ls'
+          _ -> []
+      Left AllCapit:ls ->
+        case join ls of
+          next:ls' -> T.toUpper next : ls'
+          _ -> []
+      Left (Missing cid):ls -> join (Right (T.pack (printf "[%s]" (show cid))) : ls)
+      [] -> []
+      x -> error $ printf "Unhandled term in lin2string: %s" (show x)
+
+    -- Process concats, tuples, pre into flat list
+    flatten :: [LinFun] -> [Either LinFun Text]
+    flatten [] = []
+    flatten (l:ls) = case l of
+      Empty -> flatten ls
+      Token "" -> flatten ls
+      Token tok -> Right tok : flatten ls
+      Concat l1 l2 -> flatten (l1 : l2 : ls)
+      Tuple [l] -> flatten (l:ls)
+      Tuple (l:_) -> flatten (l:ls) -- unselected table, just choose first option (see e.g. FoodsJpn)
+      Pre pts df ->
+        let
+          f = flatten ls
+          ch = case dropWhile isLeft f of
+            Right next:_ ->
+              let matches = [ l | (pfxs, l) <- pts, any (`T.isPrefixOf` next) pfxs ]
+              in  if null matches then df else head matches
+            _ -> df
+        in flatten (ch:ls)
+      x -> Left x : flatten ls
+
+-- | List indexing with more verbose error messages
+(!!) :: (Show a) => [a] -> Int -> a
+(!!) xs i
+  | i < 0 = error $ printf "!!: index %d too small for list: %s" i (show xs)
+  | i > length xs - 1 = error $ printf "!!: index %d too large for list: %s" i (show xs)
+  | otherwise = xs Prelude.!! i
+
+isIx :: LinFun -> Bool
+isIx (Ix _) = True
+isIx _ = False

src/runtime/haskell/LPGF/Internal.hs

@@ -0,0 +1,227 @@
+{-# LANGUAGE LambdaCase #-}
+
+module LPGF.Internal where
+
+import PGF.CId
+import PGF ()
+
+import Control.Monad (liftM, liftM2, forM_)
+import qualified Control.Monad.Writer as CMW
+import Data.Binary (Binary, put, get, putWord8, getWord8, encodeFile)
+import qualified Data.IntMap as IntMap
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+
+-- | Linearisation-only PGF
+data LPGF = LPGF {
+  absname   :: CId,
+  abstract  :: Abstract,
+  concretes :: Map.Map CId Concrete
+} deriving (Show)
+
+-- | Abstract syntax (currently empty)
+data Abstract = Abstract {
+} deriving (Show)
+
+-- | Concrete syntax
+data Concrete = Concrete {
+  toks    :: IntMap.IntMap Text, -- ^ all strings are stored exactly once here
+  -- lincats :: Map.Map CId LinType, -- ^ a linearization type for each category
+  lins    :: Map.Map CId LinFun  -- ^ a linearization function for each function
+} deriving (Show)
+
+-- | Abstract function type
+-- data Type = Type [CId] CId
+--   deriving (Show)
+
+-- -- | Linearisation type
+-- data LinType =
+--     StrType
+--   | IxType Int
+--   | ProductType [LinType]
+--   deriving (Show)
+
+-- | Linearisation function
+data LinFun =
+  -- Additions
+    Error String -- ^ a runtime error, should probably not be supported at all
+  | Bind -- ^ join adjacent tokens
+  | Space -- ^ space between adjacent tokens
+  | Capit -- ^ capitalise next character
+  | AllCapit -- ^ capitalise next word
+  | Pre [([Text], LinFun)] LinFun
+  | Missing CId -- ^ missing definition (inserted at runtime)
+
+  -- From original definition in paper
+  | Empty
+  | Token Text
+  | Concat LinFun LinFun
+  | Ix Int
+  | Tuple [LinFun]
+  | Projection LinFun LinFun
+  | Argument Int
+
+  -- For reducing LPGF file when stored
+  | PreIx [(Int, LinFun)] LinFun -- ^ index into `toks` map (must apply read to convert to list)
+  | TokenIx Int -- ^ index into `toks` map
+
+  deriving (Show, Read)
+
+instance Binary LPGF where
+  put lpgf = do
+    put (absname lpgf)
+    put (abstract lpgf)
+    put (concretes lpgf)
+  get = do
+    an <- get
+    abs <- get
+    concs <- get
+    return $ LPGF {
+      absname = an,
+      abstract = abs,
+      concretes = concs
+    }
+
+instance Binary Abstract where
+  put abs = return ()
+  get = return $ Abstract {}
+
+instance Binary Concrete where
+  put concr = do
+    put (toks concr)
+    put (lins concr)
+  get = do
+    ts <- get
+    ls <- get
+    return $ Concrete {
+      toks = ts,
+      lins = ls
+    }
+
+instance Binary LinFun where
+  put = \case
+    Error e          -> putWord8 0 >> put e
+    Bind             -> putWord8 1
+    Space            -> putWord8 2
+    Capit            -> putWord8 3
+    AllCapit         -> putWord8 4
+    Pre ps d         -> putWord8 5 >> put (ps,d)
+    Missing f        -> putWord8 13 >> put f
+
+    Empty            -> putWord8 6
+    Token t          -> putWord8 7 >> put t
+    Concat l1 l2     -> putWord8 8 >> put (l1,l2)
+    Ix i             -> putWord8 9 >> put i
+    Tuple ls         -> putWord8 10 >> put ls
+    Projection l1 l2 -> putWord8 11 >> put (l1,l2)
+    Argument i       -> putWord8 12 >> put i
+
+    PreIx ps d       -> putWord8 15 >> put (ps,d)
+    TokenIx i        -> putWord8 14 >> put i
+
+  get = do
+    tag <- getWord8
+    case tag of
+      0  -> liftM  Error get
+      1  -> return Bind
+      2  -> return Space
+      3  -> return Capit
+      4  -> return AllCapit
+      5  -> liftM2 Pre get get
+      13 -> liftM  Missing get
+
+      6  -> return Empty
+      7  -> liftM  Token get
+      8  -> liftM2 Concat get get
+      9  -> liftM  Ix get
+      10 -> liftM  Tuple get
+      11 -> liftM2 Projection get get
+      12 -> liftM  Argument get
+
+      15 -> liftM2 PreIx get get
+      14 -> liftM  TokenIx get
+      _  -> fail "Failed to decode LPGF binary format"
+
+instance Binary Text where
+  put = put . TE.encodeUtf8
+  get = liftM TE.decodeUtf8 get
+
+encodeFile :: FilePath -> LPGF -> IO ()
+encodeFile = Data.Binary.encodeFile
+
+------------------------------------------------------------------------------
+-- Utilities
+
+-- | Helper for building concat trees
+mkConcat :: [LinFun] -> LinFun
+mkConcat [] = Empty
+mkConcat [x] = x
+mkConcat xs = foldl1 Concat xs
+
+-- | Helper for unfolding concat trees
+unConcat :: LinFun -> [LinFun]
+unConcat (Concat l1 l2) = concatMap unConcat [l1, l2]
+unConcat lf = [lf]
+
+------------------------------------------------------------------------------
+-- Pretty-printing
+
+type Doc = CMW.Writer [String] ()
+
+render :: Doc -> String
+render = unlines . CMW.execWriter
+
+class PP a where
+  pp :: a -> Doc
+
+instance PP LPGF where
+  pp (LPGF _ _ cncs) = mapM_ pp cncs
+
+instance PP Concrete where
+  pp (Concrete toks lins) = do
+    forM_ (IntMap.toList toks) $ \(i,tok) ->
+      CMW.tell [show i ++ " " ++ T.unpack tok]
+    CMW.tell [""]
+    forM_ (Map.toList lins) $ \(cid,lin) -> do
+      CMW.tell ["# " ++ showCId cid]
+      pp lin
+      CMW.tell [""]
+
+instance PP LinFun where
+  pp = pp' 0
+    where
+      pp' n = \case
+        Pre ps d -> do
+          p "Pre"
+          CMW.tell [ replicate (2*(n+1)) ' ' ++ show p | p <- ps ]
+          pp' (n+1) d
+
+        c@(Concat l1 l2) -> do
+          let ts = unConcat c
+          if any isDeep ts
+          then do
+            p "Concat"
+            mapM_ (pp' (n+1)) ts
+          else
+            p $ "Concat " ++ show ts
+        Tuple ls | any isDeep ls -> do
+          p "Tuple"
+          mapM_ (pp' (n+1)) ls
+        Projection l1 l2 | isDeep l1 || isDeep l2 -> do
+          p "Projection"
+          pp' (n+1) l1
+          pp' (n+1) l2
+        t -> p $ show t
+        where
+          p :: String -> Doc
+          p t = CMW.tell [ replicate (2*n) ' ' ++ t ]
+
+      isDeep = not . isTerm
+      isTerm = \case
+        Pre _ _ -> False
+        Concat _ _ -> False
+        Tuple _ -> False
+        Projection _ _ -> False
+        _ -> True

src/runtime/haskell/PGF/Binary.hs

@@ -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)

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
 
 -----------------------------------------------------

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.10.3, GHC==8.0.2, GHC==8.10.4
-tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2
 
-Library
+library
-  default-language:    Haskell2010
+  default-language: Haskell2010
-  build-depends: base >= 4.6 && <5,
+  build-depends:
-                 array,
+    array >= 0.5.1 && < 0.6,
-                 containers,
+    base >= 4.9.1 && < 4.15,
-                 bytestring,
+    bytestring >= 0.10.8 && < 0.11,
-                 utf8-string,
+    containers >= 0.5.7 && < 0.7,
-                 random,
+    ghc-prim >= 0.5.0 && < 0.7,
-                 pretty,
+    mtl >= 2.2.1 && < 2.3,
-                 mtl,
+    pretty >= 1.1.3 && < 1.2,
-                 exceptions
+    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

src/runtime/haskell/stack-ghc7.10.3.yaml

@@ -0,0 +1,3 @@
+resolver: lts-6.35 # ghc 7.10.3
+
+allow-newer: true

src/runtime/haskell/stack-ghc8.0.2.yaml

@@ -0,0 +1 @@
+resolver: lts-9.21 # ghc 8.0.2

src/runtime/haskell/stack-ghc8.10.4.yaml

@@ -0,0 +1 @@
+resolver: lts-18.0 # ghc 8.10.4

src/server/PGFService.hs

@@ -151,29 +151,37 @@ getFile get path =
 cpgfMain qsem command (t,(pgf,pc)) =
   case command of
     "c-parse"       -> withQSem qsem $
-                       out t=<< join (parse # input % start % limit % treeopts)
+                       out t=<< join (parse # input % cat % start % limit % treeopts)
     "c-parseToChart"-> withQSem qsem $
-                       out t=<< join (parseToChart # input % limit)
+                       out t=<< join (parseToChart # input % cat % limit)
     "c-linearize"   -> out t=<< lin # tree % to
     "c-bracketedLinearize"
                     -> out t=<< bracketedLin # tree % to
     "c-linearizeAll"-> out t=<< linAll # tree % to
     "c-translate"   -> withQSem qsem $
-                       out t=<<join(trans # input % to % start % limit%treeopts)
+                       out t=<<join(trans # input % cat % to % start % limit%treeopts)
     "c-lookupmorpho"-> out t=<< morpho # from1 % textInput
     "c-lookupcohorts"->out t=<< cohorts # from1 % getInput "filter" % textInput
     "c-flush"       -> out t=<< flush
     "c-grammar"     -> out t grammar
     "c-abstrtree"   -> outputGraphviz=<< C.graphvizAbstractTree pgf C.graphvizDefaults # tree
     "c-parsetree"   -> outputGraphviz=<< (\cnc -> C.graphvizParseTree cnc C.graphvizDefaults) . snd # from1 %tree
-    "c-wordforword" -> out t =<< wordforword # input % to
+    "c-wordforword" -> out t =<< wordforword # input % cat % to
     _               -> badRequest "Unknown command" command
   where
     flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
                         performGC
                         return $ showJSON ()
 
-    cat = C.startCat pgf
+    cat :: CGI C.Type
+    cat =
+       do mcat  <- getInput1 "cat"
+          case mcat of
+            Nothing -> return (C.startCat pgf)
+            Just cat -> case C.readType cat of
+                          Nothing  -> badRequest "Bad category" cat
+                          Just typ -> return typ
+
     langs = C.languages pgf
 
     grammar = showJSON $ makeObj
@@ -184,8 +192,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
       where
         languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
 
-    parse input@((from,_),_) start mlimit (trie,json) =
+    parse input@((from,_),_) cat start mlimit (trie,json) =
-        do r <- parse' start mlimit input
+        do r <- parse' cat start mlimit input
            return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
 
     jsonParseResult json = either bad good
@@ -195,7 +203,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
         tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
 
     -- Without caching parse results:
-    parse' start mlimit ((from,concr),input) =
+    parse' cat start mlimit ((from,concr),input) =
         case C.parseWithHeuristics concr cat input (-1) callbacks of
           C.ParseOk ts        -> return (Right (maybe id take mlimit (drop start ts)))
           C.ParseFailed _ tok -> return (Left tok)
@@ -221,7 +229,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                              -- remove unused parse results after 2 minutes
 -}
 
-    parseToChart ((from,concr),input) mlimit =
+    parseToChart ((from,concr),input) cat mlimit =
       do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
                 C.ParseOk chart     -> return (good chart)
                 C.ParseFailed _ tok -> return (bad tok)
@@ -262,8 +270,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
     bracketedLin' tree (tos,unlex) =
         [makeObj ["to".=to,"brackets".=showJSON (C.bracketedLinearize c tree)]|(to,c)<-tos]
 
-    trans input@((from,_),_) to start mlimit (trie,jsontree) =
+    trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
-      do parses <- parse' start mlimit input
+      do parses <- parse' cat start mlimit input
          return $
            showJSON [ makeObj ["from".=from,
                                "translations".= jsonParses parses]]
@@ -297,7 +305,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                       _              -> id)
                                      (C.lookupCohorts concr input)]
 
-    wordforword input@((from,_),_) = jsonWFW from . wordforword' input
+    wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
 
     jsonWFW from rs =
       showJSON
@@ -307,7 +315,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                         [makeObj["to".=to,"text".=text]
                                          | (to,text)<-rs]]]]]
 
-    wordforword' inp@((from,concr),input) (tos,unlex) =
+    wordforword' inp@((from,concr),input) cat (tos,unlex) =
         [(to,unlex . unwords $ map (lin_word' c) pws)
          |let pws=map parse_word' (words input),(to,c)<-tos]
       where
@@ -1024,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

src/server/URLEncoding.hs

@@ -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'
+              | otherwise = y:unfoldr f p x'
-			      where (y, x') = f 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
+    if x == x' then
-	    ([], xs)
+        ([], xs)
-	else
+    else
-	    let (ys, zs) = breakAt x xs
+        let (ys, zs) = breakAt x xs
-	    in  (x':ys, zs)
+        in  (x':ys, zs)

src/server/transfer/Fold.hs

@@ -13,8 +13,8 @@ fold t =
   case unApp t of
     Just (i,[x])  ->
         case M.lookup i foldable of
-	        Just j -> appFold j x
+          Just j -> appFold j x
-	        _      -> mkApp i [fold x]
+          _      -> mkApp i [fold x]
     Just (i,xs)   -> mkApp i $ map fold xs
     _             -> t
 

src/www/gfse/index.html

@@ -7,7 +7,7 @@
 <link rel="alternate stylesheet" type="text/css" href="molto.css" title="MOLTO">
 <link rel="stylesheet" type="text/css" href="../minibar/minibar.css">
 <link rel="stylesheet" type="text/css" href="../syntax-editor/editor.css">
-<link rel="stylesheet" type="text/css" href="https://www.grammaticalframework.org/wordnet/gf-wordnet.css">
+<link rel="stylesheet" type="text/css" href="../wordnet/gf-wordnet.css">
 
 
 <link rel=author href="http://www.cse.chalmers.se/~hallgren/" title="Thomas Hallgren">
@@ -62,9 +62,9 @@ HTML
 <script type="text/javascript" src="../syntax-editor/ast.js"></script>
 <script type="text/javascript" src="../syntax-editor/editor_menu.js"></script>
 <script type="text/javascript" src="../syntax-editor/editor.js"></script>
-<script type="text/javascript" src="https://www.grammaticalframework.org/wordnet/js/gf-wordnet.js"></script>
+<script type="text/javascript" src="../wordnet/js/gf-wordnet.js"></script>
-<script type="text/javascript" src="https://www.grammaticalframework.org/wordnet/js/tsnejs.js"></script>
+<script src="https://unpkg.com/vis-network@9.0.4/standalone/umd/vis-network.min.js"></script>
-<script type="text/javascript" src="https://www.grammaticalframework.org/wordnet/js/wordcloud2.js"></script>
+<script type="text/javascript" src="../wordnet/js/wordcloud2.js"></script>
 
 <div id="search_popup" class="search_popup">
 <table id="domains" class="selector">

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
+#   gf:
+#     c-runtime: true
+#
+# extra-lib-dirs:
+#   - /usr/local/lib

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

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

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

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

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

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