more comments

now linearization is working
better error handling and an API for linearizations
2022-09-12 12:20:30 +02:00 · 2022-09-12 12:11:56 +02:00 · 2022-09-12 12:06:40 +02:00 · 2022-09-12 11:03:15 +02:00 · 2022-09-12 10:55:26 +02:00 · 2022-09-01 13:28:49 +02:00
290 changed files with 15099 additions and 68523 deletions
--- a/.github/workflows/build-all-versions.yml
+++ b/.github/workflows/build-all-versions.yml
@@ -0,0 +1,103 @@
+# Based on the template here: https://kodimensional.dev/github-actions
+name: Build with stack and cabal
+
+# Trigger the workflow on push or pull request, but only for the master branch
+on:
+  pull_request:
+  push:
+    branches: [master]
+
+jobs:
+  cabal:
+    name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
+    runs-on: ${{ matrix.os }}
+    strategy:
+      matrix:
+        os: [ubuntu-latest, macos-latest, windows-latest]
+        cabal: ["latest"]
+        ghc:
+          - "8.6.5"
+          - "8.8.3"
+          - "8.10.7"
+        exclude:
+          - os: macos-latest
+            ghc: 8.8.3
+          - os: macos-latest
+            ghc: 8.6.5
+          - os: windows-latest
+            ghc: 8.8.3
+          - os: windows-latest
+            ghc: 8.6.5
+
+    steps:
+    - uses: actions/checkout@v2
+      if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+    - uses: haskell/actions/setup@v1.2.9
+      id: setup-haskell-cabal
+      name: Setup Haskell
+      with:
+        ghc-version: ${{ matrix.ghc }}
+        cabal-version: ${{ matrix.cabal }}
+
+    - name: Freeze
+      run: |
+        cabal freeze
+
+    - uses: actions/cache@v1
+      name: Cache ~/.cabal/store
+      with:
+        path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
+        key: ${{ runner.os }}-${{ matrix.ghc }}
+        # key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+
+    - name: Build
+      run: |
+        cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
+        cabal build all
+
+    # - name: Test
+    #   run: |
+    #     cabal test all
+
+  stack:
+    name: stack / ghc ${{ matrix.ghc }}
+    runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        stack: ["latest"]
+        ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2"]
+        # ghc: ["8.8.3"]
+
+    steps:
+    - uses: actions/checkout@v2
+      if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+    - uses: haskell/actions/setup@v1.2.9
+      name: Setup Haskell Stack
+      with:
+        ghc-version: ${{ matrix.ghc }}
+        stack-version: 'latest'
+        enable-stack: true
+
+
+    # Fix linker errrors on ghc-7.10.3 for ubuntu (see https://github.com/commercialhaskell/stack/blob/255cd830627870cdef34b5e54d670ef07882523e/doc/faq.md#i-get-strange-ld-errors-about-recompiling-with--fpic)
+    - run: sed -i.bak 's/"C compiler link flags", "/&-no-pie /' /home/runner/.ghcup/ghc/7.10.3/lib/ghc-7.10.3/settings
+      if: matrix.ghc == '7.10.3'
+
+    - uses: actions/cache@v1
+      name: Cache ~/.stack
+      with:
+        path: ~/.stack
+        key: ${{ runner.os }}-${{ matrix.ghc }}-stack--${{ hashFiles(format('stack-ghc{0}', matrix.ghc)) }}
+        restore-keys: |
+             ${{ runner.os }}-${{ matrix.ghc }}-stack
+
+    - name: Build
+      run: |
+        stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
+        # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
+
+    - name: Test
+      run: |
+        stack test --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
--- a/.github/workflows/build-binary-packages.yml
+++ b/.github/workflows/build-binary-packages.yml
@@ -0,0 +1,230 @@
+name: Build Binary Packages
+
+on:
+  workflow_dispatch:
+  release: 
+    types: ["created"]
+
+jobs:
+
+# ---
+
+  ubuntu:
+    name: Build Ubuntu package
+    strategy:
+      matrix:
+        os:
+        - ubuntu-18.04
+        - ubuntu-20.04
+
+    runs-on: ${{ matrix.os }}
+
+    steps:
+    - uses: actions/checkout@v2
+
+    # Note: `haskell-platform` is listed as requirement in debian/control,
+    # which is why it's installed using apt instead of the Setup Haskell action.
+
+    # - name: Setup Haskell
+    #   uses: actions/setup-haskell@v1
+    #   id: setup-haskell-cabal
+    #   with:
+    #     ghc-version: ${{ matrix.ghc }}
+    #     cabal-version: ${{ matrix.cabal }}
+
+    - name: Install build tools
+      run: |
+        sudo apt-get update
+        sudo apt-get install -y \
+          make \
+          dpkg-dev \
+          debhelper \
+          haskell-platform \
+          libghc-json-dev \
+          python-dev \
+          default-jdk \
+          libtool-bin
+
+    - name: Build package
+      run: |
+        make deb
+
+    - name: Copy package
+      run: |
+        cp ../gf_*.deb dist/
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@v2
+      with:
+        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
+    strategy:
+      matrix:
+        ghc: ["8.6.5"]
+        cabal: ["2.4"]
+        os: ["macos-10.15"]
+    runs-on: ${{ matrix.os }}
+
+    steps:
+    - uses: actions/checkout@v2
+
+    - name: Setup Haskell
+      uses: actions/setup-haskell@v1
+      id: setup-haskell-cabal
+      with:
+        ghc-version: ${{ matrix.ghc }}
+        cabal-version: ${{ matrix.cabal }}
+
+    - name: Install build tools
+      run: |
+        brew install \
+          automake
+        cabal v1-install alex happy
+
+    - name: Build package
+      run: |
+        sudo mkdir -p /Library/Java/Home
+        sudo ln -s /usr/local/opt/openjdk/include /Library/Java/Home/include
+        make pkg
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@v2
+      with:
+        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
+    strategy:
+      matrix:
+        ghc: ["8.6.5"]
+        cabal: ["2.4"]
+        os: ["windows-2019"]
+    runs-on: ${{ matrix.os }}
+
+    steps:
+    - uses: actions/checkout@v2
+
+    - name: Setup MSYS2
+      uses: msys2/setup-msys2@v2
+      with:
+        install: >-
+          base-devel
+          gcc
+          python-devel
+
+    - name: Prepare dist folder
+      shell: msys2 {0}
+      run: |
+        mkdir /c/tmp-dist
+        mkdir /c/tmp-dist/c
+        mkdir /c/tmp-dist/java
+        mkdir /c/tmp-dist/python
+
+    - name: Build C runtime
+      shell: msys2 {0}
+      run: |
+        cd src/runtime/c
+        autoreconf -i
+        ./configure
+        make
+        make install
+        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 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 \"${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 jpgf.jar /c/tmp-dist/java
+
+    - name: Build Python bindings
+      shell: msys2 {0}
+      env:
+        EXTRA_INCLUDE_DIRS: /mingw64/include
+        EXTRA_LIB_DIRS: /mingw64/lib
+      run: |
+        cd src/runtime/python
+        python setup.py build
+        python setup.py install
+        cp /usr/lib/python3.9/site-packages/pgf* /c/tmp-dist/python
+
+    - name: Setup Haskell
+      uses: actions/setup-haskell@v1
+      id: setup-haskell-cabal
+      with:
+        ghc-version: ${{ matrix.ghc }}
+        cabal-version: ${{ matrix.cabal }}
+
+    - name: Install Haskell build tools
+      run: |
+        cabal install alex happy
+
+    - name: Build GF
+      run: |
+        cabal install --only-dependencies -fserver
+        cabal configure -fserver
+        cabal build
+        copy dist\build\gf\gf.exe C:\tmp-dist
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@v2
+      with:
+        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
--- a/.github/workflows/build-python-package.yml
+++ b/.github/workflows/build-python-package.yml
@@ -0,0 +1,98 @@
+name: Build & Publish Python Package
+
+# Trigger the workflow on push or pull request, but only for the master branch
+on:
+  pull_request:
+  push:
+    branches: [master]
+
+jobs:
+  build_wheels:
+    name: Build wheel on ${{ matrix.os }}
+    runs-on: ${{ matrix.os }}
+    strategy:
+      fail-fast: true
+      matrix:
+        os: [ubuntu-18.04, macos-10.15]
+
+    steps:
+    - uses: actions/checkout@v1
+
+    - uses: actions/setup-python@v1
+      name: Install Python
+      with:
+        python-version: '3.7'
+
+    - name: Install cibuildwheel
+      run: |
+        python -m pip install git+https://github.com/joerick/cibuildwheel.git@main
+
+    - name: Install build tools for OSX
+      if: startsWith(matrix.os, 'macos')
+      run: |
+        brew install automake
+
+    - name: Build wheels on Linux
+      if: startsWith(matrix.os, 'macos') != true
+      env:
+        CIBW_BEFORE_BUILD: cd src/runtime/c && autoreconf -i && ./configure && make && make install
+      run: |
+        python -m cibuildwheel src/runtime/python --output-dir wheelhouse
+
+    - name: Build wheels on OSX
+      if: startsWith(matrix.os, 'macos')
+      env:
+        CIBW_BEFORE_BUILD: cd src/runtime/c && glibtoolize && autoreconf -i && ./configure && make && make install
+      run: |
+        python -m cibuildwheel src/runtime/python --output-dir wheelhouse
+
+    - uses: actions/upload-artifact@v2
+      with:
+        path: ./wheelhouse
+
+  build_sdist:
+    name: Build source distribution
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2
+
+      - uses: actions/setup-python@v2
+        name: Install Python
+        with:
+          python-version: '3.7'
+
+      - name: Build sdist
+        run: cd src/runtime/python && python setup.py sdist
+
+      - uses: actions/upload-artifact@v2
+        with:
+          path: ./src/runtime/python/dist/*.tar.gz
+
+  upload_pypi:
+    name: Upload to PyPI
+    needs: [build_wheels, build_sdist]
+    runs-on: ubuntu-latest
+    if: github.ref == 'refs/heads/master' && github.event_name == 'push'
+
+    steps:
+      - uses: actions/checkout@v2
+
+      - name: Set up Python
+        uses: actions/setup-python@v2
+        with:
+          python-version: '3.x'
+
+      - name: Install twine
+        run: pip install twine
+
+      - uses: actions/download-artifact@v2
+        with:
+          name: artifact
+          path: ./dist
+
+      - name: Publish
+        env:
+          TWINE_USERNAME: __token__
+          TWINE_PASSWORD: ${{ secrets.pypi_password }}
+        run: |
+          (cd ./src/runtime/python && curl -I --fail https://pypi.org/project/$(python setup.py --name)/$(python setup.py --version)/) || twine upload dist/*
--- a/.gitignore
+++ b/.gitignore
@@ -5,7 +5,14 @@
 *.jar
 *.gfo
 *.pgf
+debian/.debhelper
+debian/debhelper-build-stamp
+debian/gf
+debian/gf.debhelper.log
+debian/gf.substvars
+debian/files
 dist/
+dist-newstyle/
 src/runtime/c/.libs/
 src/runtime/c/Makefile
 src/runtime/c/Makefile.in
@@ -44,16 +51,23 @@ cabal.sandbox.config
 .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
 demos/translation.html
 doc/tutorial/gf-tutorial.html
+doc/index.html
 doc/gf-bibliography.html
 doc/gf-developers.html
 doc/gf-editor-modes.html
 doc/gf-people.html
-doc/gf-reference.html
+doc/gf-refman.html
 doc/gf-shell-reference.html
 doc/icfp-2012.html
 download/*.html
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,14 +0,0 @@
-sudo: required
-
-language: c
-
-services:
-  - docker
-
-before_install:
-  - docker pull odanoburu/gf-src:3.9
-
-script:
-  - |
-    docker run --mount src="$(pwd)",target=/home/gfer,type=bind odanoburu/gf-src:3.9 /bin/bash -c "cd /home/gfer/src/runtime/c &&
-    autoreconf -i && ./configure && make && make install ; cd /home/gfer ; cabal install -fserver -fc-runtime --extra-lib-dirs='/usr/local/lib'"
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -0,0 +1,11 @@
+### New since 3.11 (WIP)
+
+- Added a changelog!
+
+### 3.11
+
+See <https://www.grammaticalframework.org/download/release-3.11.html>
+
+### 3.10
+
+See <https://www.grammaticalframework.org/download/release-3.10.html>
--- a/47
+++ b/47
@@ -1,31 +1,48 @@
-.PHONY: all build install doc clean gf html deb pkg bintar sdist
+.PHONY: all build install doc clean html deb pkg bintar sdist

 # This gets the numeric part of the version from the cabal file
 VERSION=$(shell sed -ne "s/^version: *\([0-9.]*\).*/\1/p" gf.cabal)

+# Check if stack is installed
+STACK=$(shell if hash stack 2>/dev/null; then echo "1"; else echo "0"; fi)
+
+# Check if cabal >= 2.4 is installed (with v1- and v2- commands)
+CABAL_NEW=$(shell if cabal v1-repl --help >/dev/null 2>&1 ; then echo "1"; else echo "0"; fi)
+
+ifeq ($(STACK),1)
+  CMD=stack
+else
+  CMD=cabal
+  ifeq ($(CABAL_NEW),1)
+    CMD_PFX=v1-
+  endif
+endif
+
 all: build

 dist/setup-config: gf.cabal Setup.hs WebSetup.hs
-	cabal configure
+ifneq ($(STACK),1)
+	cabal ${CMD_PFX}configure
+endif

 build: dist/setup-config
-	cabal build
+	${CMD} ${CMD_PFX}build

 install:
-	cabal copy
-	cabal register
+ifeq ($(STACK),1)
+	stack install
+else
+	cabal ${CMD_PFX}copy
+	cabal ${CMD_PFX}register
+endif

 doc:
-	cabal haddock
+	${CMD} ${CMD_PFX}haddock

 clean:
-	cabal clean
+	${CMD} ${CMD_PFX}clean
 	bash bin/clean_html

-gf:
-	cabal build rgl-none
-	strip dist/build/gf/gf
-
 html::
 	bash bin/update_html

@@ -35,7 +52,7 @@ html::
 deb:
 	dpkg-buildpackage -b -uc

-# Make an OS X Installer package
+# Make a macOS installer package
 pkg:
 	FMT=pkg bash bin/build-binary-dist.sh

@@ -48,6 +65,6 @@ bintar:

 # Make a source tar.gz distribution using git to make sure that everything is included.
 # We put the distribution in dist/ so it is removed on `make clean`
-sdist:
-	test -d dist || mkdir dist
-	git archive --format=tar.gz --output=dist/gf-${VERSION}.tar.gz HEAD
+# sdist:
+# 	test -d dist || mkdir dist
+# 	git archive --format=tar.gz --output=dist/gf-${VERSION}.tar.gz HEAD
--- a/README.md
+++ b/README.md
@@ -1,9 +1,7 @@
-![GF Logo](doc/Logos/gf1.svg)
+![GF Logo](https://www.grammaticalframework.org/doc/Logos/gf1.svg)

 # Grammatical Framework (GF)

-[![Build Status](https://travis-ci.org/GrammaticalFramework/gf-core.svg?branch=master)](https://travis-ci.org/GrammaticalFramework/gf-core)
-
 The Grammatical Framework is a grammar formalism based on type theory.
 It consists of:

@@ -32,13 +30,16 @@ GF particularly addresses four aspects of grammars:

 ## Compilation and installation

-The simplest way of installing GF is with the command:
+The simplest way of installing GF from source is with the command:
 ```
 cabal install
 ```
+or:
+```
+stack install
+```

-For more details, see the [download page](http://www.grammaticalframework.org/download/index.html)
-and [developers manual](http://www.grammaticalframework.org/doc/gf-developers.html).
+For more information, including links to precompiled binaries, see the [download page](https://www.grammaticalframework.org/download/index.html).

 ## About this repository

--- a/RELEASE.md
+++ b/RELEASE.md
@@ -0,0 +1,69 @@
+# GF Core releases
+
+**Note:**
+The RGL is now released completely separately from GF Core.
+See the [RGL's RELEASE.md](https://github.com/GrammaticalFramework/gf-rgl/blob/master/RELEASE.md).
+
+## Creating a new release
+
+### 1. Prepare the repository
+
+**Web pages**
+
+1. Create `download/index-X.Y.md` with installation instructions.
+2. Create `download/release-X.Y.md` with changelog information.
+3. Update `download/index.html` to redirect to the new version.
+4. Add announcement in news section in `index.html`.
+
+**Version numbers**
+
+1. Update version number in `gf.cabal` (ommitting `-git` suffix).
+2. Add a new line in `debian/changelog`.
+
+### 2. Create GitHub release
+
+1. When the above changes are committed to the `master` branch in the repository
+  and pushed, check that all CI workflows are successful (fixing as necessary):
+  - <https://github.com/GrammaticalFramework/gf-core/actions>
+  - <https://travis-ci.org/github/GrammaticalFramework/gf-core>
+2. Create a GitHub release [here](https://github.com/GrammaticalFramework/gf-core/releases/new):
+  - Tag version format `RELEASE-X.Y`
+  - Title: "GF X.Y"
+  - Description: mention major changes since last release
+3. Publish the release to trigger the building of the binary packages (below).
+
+### 3. Binary packages
+
+The binaries will be built automatically by GitHub Actions when the release is created,
+but the generated _artifacts_ must be manually attached to the release as _assets_.
+
+1. Go to the [actions page](https://github.com/GrammaticalFramework/gf-core/actions) and click "Build Binary Packages" under _Workflows_.
+2. Choose the workflow run corresponding to the newly created release.
+3. Download the artifacts locally. Extract the Ubuntu and macOS ones to get the `.deb` and `.pkg` files.
+4. Go back to the [releases page](https://github.com/GrammaticalFramework/gf-core/releases) and click to edit the release information.
+5. Add the downloaded artifacts as release assets, giving them names with format `gf-X.Y-PLATFORM.EXT` (e.g. `gf-3.11-macos.pkg`).
+
+### 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 `stack sdist --test-tarball` and address any issues.
+2. Upload the package, either:
+    1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file generated by the previous command.
+    2. **via Stack**: `stack upload . --candidate`
+3. After testing the candidate, publish it:
+    1. **Manually**: visit <https://hackage.haskell.org/package/gf-X.Y.Z/candidate/publish>
+    1. **via Stack**: `stack upload .`
+4. If the documentation-building fails on the Hackage server, do:
+```
+cabal v2-haddock --builddir=dist/docs --haddock-for-hackage --enable-doc
+cabal upload --documentation dist/docs/*-docs.tar.gz
+```
+
+## Miscellaneous
+
+### What is the tag `GF-3.10`?
+
+For GF 3.10, the Core and RGL repositories had already been separated, however
+the binary packages still included the RGL. `GF-3.10` is a tag that was created
+in both repositories ([gf-core](https://github.com/GrammaticalFramework/gf-core/releases/tag/GF-3.10) and [gf-rgl](https://github.com/GrammaticalFramework/gf-rgl/releases/tag/GF-3.10)) to indicate which versions of each went into the binaries.
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,3 +1,4 @@
+import Distribution.System(Platform(..),OS(..))
 import Distribution.Simple(defaultMainWithHooks,UserHooks(..),simpleUserHooks)
 import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs,datadir)
 import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..),SDistFlags(..))
@@ -18,7 +19,6 @@ main = defaultMainWithHooks simpleUserHooks
  , preInst   = gfPreInst
  , postInst  = gfPostInst
  , postCopy  = gfPostCopy
-  , sDistHook = gfSDist
  }
  where
    gfPreBuild args  = gfPre args . buildDistPref
@@ -28,17 +28,17 @@ main = defaultMainWithHooks simpleUserHooks
      return emptyHookedBuildInfo

    gfPostBuild args flags pkg lbi = do
-      noRGLmsg
+      -- noRGLmsg
      let gf = default_gf lbi
      buildWeb gf flags (pkg,lbi)

    gfPostInst args flags pkg lbi = do
-      noRGLmsg
+      -- noRGLmsg
      saveInstallPath args flags (pkg,lbi)
      installWeb (pkg,lbi)

    gfPostCopy args flags  pkg lbi = do
-      noRGLmsg
+      -- noRGLmsg
      saveCopyPath args flags (pkg,lbi)
      copyWeb flags (pkg,lbi)

@@ -73,5 +73,9 @@ dataDirFile = "DATA_DIR"
 default_gf :: LocalBuildInfo -> FilePath
 default_gf lbi = buildDir lbi </> exeName' </> exeNameReal
  where
+    -- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4
+    exeExtension = case hostPlatform lbi of
+      Platform arch Windows -> "exe"
+      _ -> ""
    exeName' = "gf"
    exeNameReal = exeName' <.> exeExtension
--- a/WebSetup.hs
+++ b/WebSetup.hs
@@ -26,6 +26,14 @@ import Distribution.PackageDescription(PackageDescription(..))
  so users won't see this message unless they check the log.)
 -}

+-- | Notice about contrib grammars
+noContribMsg :: IO ()
+noContribMsg = putStr $ unlines
+  [ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
+  , "If you want them to be built, clone the following repository in the same directory as gf-core:"
+  , "https://github.com/GrammaticalFramework/gf-contrib.git"
+  ]
+
 example_grammars :: [(String, String, [String])] -- [(pgf, subdir, source modules)]
 example_grammars =
   [("Letter.pgf","letter",letterSrc)
@@ -50,11 +58,8 @@ buildWeb gf flags (pkg,lbi) = do
  contrib_exists <- doesDirectoryExist contrib_dir
  if contrib_exists
  then mapM_ build_pgf example_grammars
-  else putStr $ unlines
-    [ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
-    , "If you want these example grammars to be built, clone this repository in the same top-level directory as GF:"
-    , "https://github.com/GrammaticalFramework/gf-contrib.git"
-    ]
+  -- else noContribMsg
+  else return ()
  where
    gfo_dir = buildDir lbi </> "examples"

--- a/bin/build-binary-dist.sh
+++ b/bin/build-binary-dist.sh
@@ -1,15 +1,18 @@
 #! /bin/bash

-### This script builds a binary distribution of GF from the source
-### package that this script is a part of. It assumes that you have installed
-### the Haskell Platform, version 2013.2.0.0 or 2012.4.0.0.
-### Two binary package formats are supported: plain tar files (.tar.gz) and
-### OS X Installer packages (.pkg).
+### This script builds a binary distribution of GF from source.
+### It assumes that you have Haskell and Cabal installed.
+### Two binary package formats are supported (specified with the FMT env var):
+### - plain tar files (.tar.gz)
+### - macOS installer packages (.pkg)

 os=$(uname)     # Operating system name (e.g. Darwin or Linux)
 hw=$(uname -m)  # Hardware name (e.g. i686 or x86_64)

-# GF version number:
+cabal="cabal v1-" # Cabal >= 2.4
+# cabal="cabal " # Cabal <= 2.2
+
+## Get GF version number from Cabal file
 ver=$(grep -i ^version: gf.cabal | sed -e 's/version://' -e 's/ //g')

 name="gf-$ver"
@@ -29,6 +32,7 @@ set -x                             # print commands before executing them
 pushd src/runtime/c
 bash setup.sh configure --prefix="$prefix"
 bash setup.sh build
+bash setup.sh install prefix="$prefix" # hack required for GF build on macOS
 bash setup.sh install prefix="$destdir$prefix"
 popd

@@ -38,11 +42,11 @@ if which >/dev/null python; then
    EXTRA_INCLUDE_DIRS="$extrainclude" EXTRA_LIB_DIRS="$extralib" python setup.py build
    python setup.py install --prefix="$destdir$prefix"
    if [ "$fmt" == pkg ] ; then
-	# A hack for Python on OS X to find the PGF modules
-	pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
-	pydest="$destdir/Library/Python/$pyver/site-packages"
-	mkdir -p "$pydest"
-	ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$pydest"
+        # A hack for Python on macOS to find the PGF modules
+        pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
+        pydest="$destdir/Library/Python/$pyver/site-packages"
+        mkdir -p "$pydest"
+        ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$pydest"
    fi
    popd
 else
@@ -53,52 +57,42 @@ fi
 if which >/dev/null javac && which >/dev/null jar ; then
    pushd src/runtime/java
    rm -f libjpgf.la # In case it contains the wrong INSTALL_PATH
-    if make CFLAGS="-I$extrainclude -L$extralib" INSTALL_PATH="$prefix/lib"
+    if make CFLAGS="-I$extrainclude -L$extralib" INSTALL_PATH="$prefix"
    then
-	make INSTALL_PATH="$destdir$prefix/lib" install
+        make INSTALL_PATH="$destdir$prefix" install
    else
-	echo "*** Skipping the Java binding because of errors"
+        echo "Skipping the Java binding because of errors"
    fi
    popd
 else
    echo "Java SDK is not installed, so the Java binding will not be included"
 fi

+## To find dynamic C run-time libraries when building GF below
+export DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib"
+
 ## Build GF, with C run-time support enabled
-cabal install -w "$ghc" --only-dependencies -fserver -fc-runtime $extra
-cabal configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
-DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib" cabal build
-  # Building the example grammars will fail, because the RGL is missing
-cabal copy --destdir="$destdir"  # create www directory
-
-## Build the RGL and copy it to $destdir
-PATH=$PWD/dist/build/gf:$PATH
-export GF_LIB_PATH="$(dirname $(find "$destdir" -name www))/lib"   # hmm
-mkdir -p "$GF_LIB_PATH"
-pushd ../gf-rgl
-make build
-make copy
-popd
-
-# Build GF again, including example grammars that need the RGL
-DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib" cabal build
+${cabal}install -w "$ghc" --only-dependencies -fserver -fc-runtime $extra
+${cabal}configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
+${cabal}build

 ## Copy GF to $destdir
-cabal copy --destdir="$destdir"
+${cabal}copy --destdir="$destdir"
 libdir=$(dirname $(find "$destdir" -name PGF.hi))
-cabal register --gen-pkg-config=$libdir/gf-$ver.conf
+${cabal}register --gen-pkg-config="$libdir/gf-$ver.conf"

 ## Create the binary distribution package
 case $fmt in
    tar.gz)
-	targz="$name-bin-$hw-$os.tar.gz"     # the final tar file
-	tar -C "$destdir/$prefix" -zcf "dist/$targz" .
-	echo "Created $targz, consider renaming it to something more user friendly"
-	;;
+        targz="$name-bin-$hw-$os.tar.gz"     # the final tar file
+        tar --directory "$destdir/$prefix" --gzip --create --file "dist/$targz" .
+        echo "Created $targz"
+        ;;
    pkg)
-	pkg=$name.pkg
-	pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
-	echo "Created $pkg"
+        pkg=$name.pkg
+        pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
+        echo "Created $pkg"
 esac

+## Cleanup
 rm -r "$destdir"
--- a/bin/clean_html
+++ b/bin/clean_html
@@ -1,8 +1,20 @@
 #!/bin/bash

-### This script finds all .t2t (txt2tags) files and deletes the corresponding html file
+# This script finds all .t2t (txt2tags) and .md (Markdown) files
+# and deletes the corresponding HTML file of the same name.

 find . -name '*.t2t' | while read t2t ; do
  html="${t2t%.t2t}.html"
-  rm -f "$html"
+  if [ -f "$html" ] ; then
+    echo "$html"
+    rm -f "$html"
+  fi
+done
+
+find . -name '*.md' | while read md ; do
+  html="${md%.md}.html"
+  if [ -f "$html" ] ; then
+    echo "$html"
+    rm -f "$html"
+  fi
 done
--- a/bin/template.html
+++ b/bin/template.html
@@ -28,16 +28,17 @@ $for(header-includes)$
  $header-includes$
 $endfor$
 </head>
-<body>
+<body class="bg-light">
+  <div class="bg-white pb-5">
 $for(include-before)$
 $include-before$
 $endfor$
-<div class="container-fluid my-5" style="max-width:1200px">
+<div class="container-fluid py-5" style="max-width:1200px">

 $if(title)$
 <header id="title-block-header">
 <a href="$rel-root$" title="Home">
-  <img src="$rel-root$/doc/Logos/gf1.svg" height="200px" class="float-md-right mb-3 bg-white" alt="GF Logo">
+  <img src="$rel-root$/doc/Logos/gf1.svg" height="200" class="float-md-right ml-3 mb-3 bg-white" alt="GF Logo">
 </a>
 <h1 class="title">$title$</h1>
 $if(subtitle)$
@@ -53,13 +54,20 @@ $endif$
 $endif$
 $if(toc)$
 <nav id="$idprefix$TOC">
-$table-of-contents$
+$if(table-of-contents)$
+  <!-- pandoc >= 2.0 -->
+  $table-of-contents$
+$else$
+  <!-- pandoc < 2.0 -->
+  $toc$
+$endif$
 </nav>
 $endif$
 $body$
 </div><!-- .container -->
+</div><!-- .bg-white -->

-<footer class="bg-light mt-5 py-5">
+<footer class="py-5">
  <div class="container">
    <div class="row">

@@ -72,7 +80,12 @@ $body$
        <ul class="list-unstyled">
          <li><a href="https://www.youtube.com/watch?v=x1LFbDQhbso">Google Tech Talk</a></li>
          <li><a href="http://cloud.grammaticalframework.org/">GF Cloud</a></li>
-          <li><a href="$rel-root$/doc/tutorial/gf-tutorial.html">Tutorial</a></li>
+          <li>
+            <a href="$rel-root$/doc/tutorial/gf-tutorial.html">Tutorial</a>
+             ·
+            <a href="$rel-root$/lib/doc/rgl-tutorial/index.html">RGL Tutorial</a>
+          </li>
+          <li><a href="$rel-root$/doc/gf-video-tutorials.html">Video Tutorials</a></li>
          <li><a href="$rel-root$/download"><strong>Download GF</strong></a></li>
        </ul>
      </div>
@@ -100,8 +113,7 @@ $body$
      </div>

      <div class="col-6 col-sm-3">
-        <h6 class="text-muted">Contribute</i>
-        </h6>
+        <h6 class="text-muted">Contribute</h6>
        <ul class="list-unstyled">
          <li><a href="http://groups.google.com/group/gf-dev">Mailing List</a></li>
          <li><a href="https://github.com/GrammaticalFramework/gf-core/issues">Issue Tracker</a></li>
@@ -116,8 +128,8 @@ $body$
        <a href="https://github.com/GrammaticalFramework/gf-rgl">RGL</a> ·
        <a href="https://github.com/GrammaticalFramework/gf-contrib">Contributions</a>
      </div>
-    <div>
-  <div>
+    </div>
+  </div>
 </footer>
 $for(include-after)$
 $include-after$
--- a/bin/update_html
+++ b/bin/update_html
@@ -1,9 +1,29 @@
 #!/bin/bash

+# Generate HTML from txt2tags (.t2t) and Markdown (.md)
+# Usage:
+# - update_html
+#   Look for all .t2t and .md files in the current directory and below,
+#   generating the output HTML when the source is newer than the HTML.
+# - update_html path/to/file.t2t path/to/another.md
+#   Generate HTML for the specified file(s), ignoring modification time.
+#
+# Requires:
+# - txt2tags for .t2t files. Tested with 2.6.
+# - pandoc for both .t2t and .md files. Tested with 1.16.0.2 and 2.3.1.
+# - the template file `template.html` in the same directory as this script.
+#
+# Tested with Ubuntu 16.04 and macOS Mojave.
+#
+# See also clean_html for removing the files generated by this script.
+
 # Path to directory where this script is
 # https://stackoverflow.com/a/246128/98600
 DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )"

+# HTML template
+template="$DIR/template.html"
+
 # Render txt2tags into html file
 # Arguments:
 # 1. txt2tags source file, e.g. download/index.t2t
@@ -22,6 +42,12 @@ function render_t2t_html {
    --outfile="$tmp" \
    --infile="$t2t"

+  # Replace <A NAME="toc3"></A> with <div id="toc3"></div> so that Pandoc retains it
+  # Do this for both cases since BSD sed doesn't support /i
+  sed -i.bak "s/<a name=\"\(.*\)\"><\/a>/<div id=\"\1\"><\/div>/" "$tmp"
+  sed -i.bak "s/<A NAME=\"\(.*\)\"><\/A>/<div id=\"\1\"><\/div>/" "$tmp"
+  rm -f "$tmp.bak"
+
  # Capture first 3 lines of t2t file: title, author, date
  # Documentation here: https://txt2tags.org/userguide/headerarea
  l1=$(head -n 1 "$t2t")
@@ -41,7 +67,8 @@ function render_t2t_html {
    --from=html \
    --to=html5 \
    --standalone \
-    --template="$DIR/template.html" \
+    --template="$template" \
+    --variable="lang:en" \
    --variable="rel-root:$relroot" \
    --metadata="title:$title" \
    --metadata="author:$author" \
@@ -60,28 +87,43 @@ function render_t2t_html {
 # Render markdown into html file
 # Arguments:
 # 1. markdown source file, e.g. download/index.md
-# 2. html target filen, e.g. download/index.html
+# 2. html target file, e.g. download/index.html
 function render_md_html {
  md="$1"
  html="$2"
  relroot="$( dirname $md | sed -E 's/^.\///' | sed -E 's/[^/]+/../g' )"

+  # Look for `show-toc: true` in metadata (first ten lines of file)
+  if head -n 10 "$md" | grep --quiet 'show-toc: true' ; then
+    tocflag='--table-of-contents'
+  else
+    tocflag=''
+  fi
+
  pandoc \
    --from=markdown \
    --to=html5 \
    --standalone \
-    --template="$DIR/template.html" \
+    $tocflag \
+    --template="$template" \
+    --variable="lang:en" \
    --variable="rel-root:$relroot" \
    "$md" \
    --output="$html"

  # Final post-processing
  if [ -f "$html" ] ; then
-    sed -i.bak "s/<table/<table class=\"table\"/" "$html" && rm "$html.bak"
+    # add "table" class to tables
+    sed -i.bak "s/<table/<table class=\"table\"/" "$html"
+    # rewrite anchors that Pandoc 1.16 ignores: [content]{#anchor} -> <span id="anchor">content</span>
+    sed -i.bak -E "s/\[(.*)\]\{#(.+)\}/<span id=\"\2\">\1<\/span>/" "$html"
+    rm -f "$html.bak"
    echo "$html"
  fi
 }

+# Main entry point
+# Script can be run in one of two modes:
 if [ $# -gt 0 ] ; then
  # Render specific file(s) from args, ignoring dates
  for file in "$@" ; do
@@ -100,14 +142,14 @@ else
  # Render all files found in cwd and deeper if source is newer
  find . -name '*.t2t' | while read file ; do
    html="${file%.t2t}.html"
-    if [ "$file" -nt "$html" ] ; then
+    if [ "$file" -nt "$html" ] || [ "$template" -nt "$html" ] ; then
      render_t2t_html "$file" "$html"
    fi
  done
  find . -name '*.md' | while read file ; do
-    if [[ "$file" == *"README.md" ]] ; then continue ; fi
+    if [[ "$file" == *"README.md" ]] || [[ "$file" == *"RELEASE.md" ]] ; then continue ; fi
    html="${file%.md}.html"
-    if [ "$file" -nt "$html" ] ; then
+    if [ "$file" -nt "$html" ] || [ "$template" -nt "$html" ] ; then
      render_md_html "$file" "$html"
    fi
  done
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,8 +1,32 @@
+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
+
+ -- Thomas Hallgren <hallgren@chalmers.se>  Fri, 18 Nov 2019 15:00:00 +0100
+
+gf (3.10.3-1) xenial bionic cosmic; urgency=low
+
+  * GF 3.10.3
+
+ -- Thomas Hallgren <hallgren@chalmers.se>  Fri,  5 Mar 2019 19:30:00 +0100
+
+gf (3.10-2) xenial bionic cosmic; urgency=low
+
+  * GF 3.10
+
+ -- Thomas Hallgren <hallgren@chalmers.se>  Fri,  5 Mar 2019 16:00:00 +0100
+
 gf (3.10-1) xenial bionic cosmic; urgency=low

  * GF 3.10

- -- Thomas Hallgren <hallgren@chalmers.se>  Fri, 30 Nov 2018 20:00:00 +0100
+ -- Thomas Hallgren <hallgren@chalmers.se>  Fri,  2 Dec 2018 15:00:00 +0100

 gf (3.9-1) vivid xenial zesty; urgency=low

--- a/debian/control
+++ b/debian/control
@@ -3,14 +3,14 @@ Section: devel
 Priority: optional
 Maintainer: Thomas Hallgren <hallgren@chalmers.se>
 Standards-Version: 3.9.2
-Build-Depends: debhelper (>= 5), haskell-platform (>= 2011.2.0.1), libghc-haskeline-dev, libghc-mtl-dev, libghc-json-dev, autoconf, automake, libtool-bin, python-dev, java-sdk, txt2tags
+Build-Depends: debhelper (>= 5), haskell-platform (>= 2011.2.0.1), libghc-haskeline-dev, libghc-mtl-dev, libghc-json-dev, autoconf, automake, libtool-bin, python-dev, java-sdk
 Homepage: http://www.grammaticalframework.org/

 Package: gf
 Architecture: any
 Depends: ${shlibs:Depends}
 Description: Tools for GF, a grammar formalism based on type theory
- Grammatical Framework (GF) is a grammar formalism based on type theory. 
+ Grammatical Framework (GF) is a grammar formalism based on type theory.
 It consists of a special-purpose programming language,
 a compiler of the language, and a generic grammar processor.
 .
--- a/debian/rules
+++ b/debian/rules
@@ -1,6 +1,6 @@
 #!/usr/bin/make -f

-%: 
+%:
 	+dh $@

 #dh_shlibdeps has a problem finding which package some of the Haskell
@@ -13,14 +13,27 @@
 override_dh_shlibdeps:
 	dh_shlibdeps --dpkg-shlibdeps-params=--ignore-missing-info

+override_dh_auto_configure:
+	cd src/runtime/c && bash setup.sh configure --prefix=/usr
+	cd src/runtime/c && bash setup.sh build
+	cabal v1-update
+	cabal v1-install --only-dependencies
+	cabal v1-configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c
+
+SET_LDL=LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
+
 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/lib
-	echo LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
-	LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal build
-	LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal copy --destdir=$(CURDIR)/debian/gf # create www directory
-	PATH=$(CURDIR)/dist/build/gf:$$PATH && export GF_LIB_PATH="$$(dirname $$(find "$(CURDIR)/debian/gf" -name www))/lib" && echo "GF_LIB_PATH=$$GF_LIB_PATH" && mkdir -p "$$GF_LIB_PATH" && ( cd ../gf-rgl && make build && make copy ) && LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal build
-	make html
+	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 v1-build
+
+override_dh_auto_install:
+	$(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
+	D="`find debian/gf -name site-packages`" && [ -n "$$D" ] && cd $$D && cd .. && mv site-packages dist-packages

 override_dh_auto_clean:
 	rm -fr dist/build
@@ -28,20 +41,6 @@ override_dh_auto_clean:
 	-cd src/runtime/java && make clean
 	-cd src/runtime/c && make clean

-override_dh_auto_configure:
-	cd src/runtime/c && bash setup.sh configure --prefix=/usr
-	cd src/runtime/c && bash setup.sh build
-	cabal update
-	cabal install --only-dependencies
-	cabal configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c
-
-override_dh_auto_install:
-	LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal 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/lib install
-	D="`find debian/gf -name site-packages`" && [ -n "$$D" ] && cd $$D && cd .. && mv site-packages dist-packages
-
 override_dh_auto_test:
 ifneq (nocheck,$(filter nocheck,$(DEB_BUILD_OPTIONS)))
 	true
--- a/doc/error-messages.txt
+++ b/doc/error-messages.txt
@@ -0,0 +1,551 @@
+Compiler.hs
+mainGFC :: Options -> [FilePath] -> IO ()
+                 _ | null fs -> fail $ "No input files."
+                 _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
+                 _ -> fail $ "Don't know what to do with these input files: " ++ unwords fs)
+
+
+----------------------------------------
+Compile.hs
+
+compileModule
+                       case length file1s of
+                         0 -> raise (render ("Unable to find: " $$ nest 2 candidates))
+                         1 -> do return $ head file1s
+                         _ -> do putIfVerb opts1 ("matched multiple candidates: " +++ show file1s)
+                                 return $ head file1s
+               else raise (render ("File" <+> file <+> "does not exist"))
+
+---------------------------------------
+Grammar.Lexer.x
+token :: P Token
+        AlexError (AI pos _ _) -> PFailed pos "lexical error"
+
+
+---------------------------------------
+Grammar.Parser.y
+
+happyError = fail "syntax error"
+
+tryLoc (c,mty,Just e) = return (c,(mty,e))
+tryLoc (c,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
+
+mkR []       = return $ RecType [] --- empty record always interpreted as record type
+mkR fs@(f:_) =
+  case f of
+    (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
+    _                     -> mapM tryR  fs >>= return . R
+  where
+    tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
+    tryRT (lab,_      ,_      ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
+
+    tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
+    tryR (lab,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
+
+
+---------------------------------------
+ModDeps.hs
+
+mkSourceGrammar :: [SourceModule] -> Err SourceGrammar
+  deplist <- either 
+               return 
+               (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ 
+
+
+checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
+   test ms = testErr (all (`notElem` ns) ms)
+                     ("import names clashing with module names among" +++ unwords (map prt ms))
+
+
+moduleDeps :: [SourceModule] -> Err Dependencies
+  deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ case mtype m of
+      MTConcrete a -> do
+        am <- lookupModuleType gr a
+        testErr (mtype am == MTAbstract) "the of-module is not an abstract syntax" 
+
+    testErr (all (compatMType ety . mtype) ests) "inappropriate extension module type" 
+
+
+---------------------------------------
+Update.hs
+
+buildAnyTree
+        Just i  -> case unifyAnyInfo m i j of
+		     Ok k  -> go (Map.insert c k map) is
+		     Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+		                             nest 4 (ppJudgement Qualified (c,i)) $$
+		                             "and" $+$
+		                             nest 4 (ppJudgement Qualified (c,j)))
+extendModule
+    unless (sameMType (mtype m) (mtype mo)) 
+            (checkError ("illegal extension type to module" <+> name))
+
+rebuildModule
+      unless (null is || mstatus mi == MSIncomplete) 
+             (checkError ("module" <+> i <+> 
+                          "has open interfaces and must therefore be declared incomplete"))
+
+         unless (isModRes m1)
+                 (checkError ("interface expected instead of" <+> i0))
+          js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
+
+     unless (stat' == MSComplete || stat == MSIncomplete) 
+             (checkError ("module" <+> i <+> "remains incomplete"))
+
+
+extendMod
+		                                 checkError ("cannot unify the information" $$ 
+		                                             nest 4 (ppJudgement Qualified (c,i)) $$
+		                                             "in module" <+> name <+> "with" $$
+		                                             nest 4 (ppJudgement Qualified (c,j)) $$
+		                                             "in module" <+> base)
+
+unifyAnyInfo
+  (ResValue (L l1 t1), ResValue (L l2 t2)) 
+      | t1==t2    -> return (ResValue (L l1 t1))
+      | otherwise -> fail ""
+
+  (AnyInd b1 m1, AnyInd b2 m2) -> do
+    testErr (b1 == b2) $ "indirection status"
+    testErr (m1 == m2) $ "different sources of indirection"
+
+unifAbsDefs _         _         = fail ""
+
+----------------------------------
+
+Rename.hs
+
+renameIdentTerm'
+        _    -> case lookupTreeManyAll showIdent opens c of
+                  [f]  -> return (f c)
+                  []   -> alt c ("constant not found:" <+> c $$
+                                 "given" <+> fsep (punctuate ',' (map fst qualifs)))
+
+                           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
+
+renameInfo
+    renLoc ren (L loc x) =
+      checkInModule cwd mi loc ("Happened in the renaming of" <+> i) $ do
+
+renameTerm
+      | otherwise -> checks [ renid' (Q (MN r,label2ident l))      -- .. and qualified expression second.
+                            , renid' t >>= \t -> return (P t l) -- try as a constant at the end
+                            , checkError ("unknown qualified constant" <+> trm)
+                            ]
+
+renamePattern env patt =
+    do r@(p',vs) <- renp patt
+       let dupl = vs \\ nub vs
+       unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear:") 4
+                                             patt)
+       return r
+
+       case c' of
+          Q d -> renp $ PM d
+          _ -> checkError ("unresolved pattern" <+> patt)
+
+          Q  _ -> checkError ("data constructor expected but" <+> ppTerm Qualified 0 c' <+> "is found instead")
+          _    -> checkError ("unresolved data constructor" <+> ppTerm Qualified 0 c')
+
+      PM c -> do
+        x <- renid (Q c)
+        c' <- case x of
+                (Q c') -> return c'
+                _      -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt)
+
+     PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
+                                                 QC c -> return (PP c [],[])
+                                                 _    -> checkError (pp "not a constructor")
+                     , return (patt, [x])
+ 
+
+
+-----------------------------------
+CheckGrammar.hs
+
+checkRestrictedInheritance :: FilePath -> SourceGrammar -> SourceModule -> Check ()
+     let illegals = [(f,is) | 
+           (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
+     case illegals of 
+       [] -> return ()
+       cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
+                         nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
+
+checkCompleteGrammar :: Options -> FilePath -> Grammar -> Module -> Module -> Check Module
+                       case info of
+                         CncCat (Just (L loc (RecType []))) _ _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
+                         _                                          -> Bad "no def lin"
+
+         where noLinOf c = checkWarn ("no linearization of" <+> c)
+
+         Ok (CncCat Nothing md mr mp mpmcfg) -> do
+           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
+           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
+         _ -> do
+           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
+
+                             _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
+
+           Ok (_,AbsFun {}) ->
+                   checkError ("lincat:"<+>c<+>"is a fun, not a cat")
+           -}
+           _ -> do checkWarn ("category" <+> c <+> "is not in abstract")
+
+checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
+         (Just (L loct ty), Nothing) -> do
+           chIn loct "operation" $
+             checkError (pp "No definition given to the operation")
+
+    ResOverload os tysts -> chIn NoLoc "overloading" $ do
+    
+       checkUniq xss = case xss of
+     x:y:xs 
+      | x == y    -> checkError $ "ambiguous for type" <+>
+                                  ppType (mkFunType (tail x) (head x))
+
+   compAbsTyp g t = case t of
+     Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g
+
+checkReservedId x =
+  when (isReservedWord x) $
+       checkWarn ("reserved word used as identifier:" <+> x)
+
+
+--------------------------------
+TypeCheck/Abstract.hs
+
+grammar2theory :: SourceGrammar -> Theory
+  Bad s -> case lookupCatContext gr m f of
+    Ok cont -> return $ cont2val cont
+    _ -> Bad s
+
+
+--------------------------------
+TypeCheck/ConcreteNew.hs
+-- Concrete.hs has all its code commented out
+
+
+--------------------------------
+TypeCheck/RConcrete.hs
+-- seems to be used more than ConcreteNew
+
+computeLType :: SourceGrammar -> Context -> Type -> Check Type
+   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) 
+
+inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
+   Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
+                                                Nothing -> checkError ("unknown in Predef:" <+> ident)
+
+   Q ident -> checks [
+     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
+     ]
+
+   QC ident -> checks [
+       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
+       ]
+
+   Vr ident -> termWith trm $ checkLookup ident g
+
+   AdHocOverload ts -> do
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
+
+   App f a -> do
+         case fty' of
+           Prod bt z arg val -> do 
+           _ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty)
+
+   S f x -> do
+       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
+
+   P t i -> do
+                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
+       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
+                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
+
+   R r -> do
+     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
+
+   T ti pts -> do  -- tries to guess: good in oper type inference
+       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
+
+   ---- 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))
+
+   ExtR r s -> do
+     case (rT', sT') of
+       (RecType rs, RecType ss) -> do
+       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
+
+   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
+
+
+getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
+   matchOverload f typs ttys = do
+         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
+                      "for" $$
+                      nest 2 (showTypes tys) $$
+                      "using" $$
+                      nest 2 (showTypes pre)
+       ([],[]) -> do
+         checkError $ "no overload instance of" <+> ppTerm Unqualified 0 f $$
+                      "for" $$
+                      nest 2 stysError $$
+                      "among" $$
+                      nest 2 (vcat stypsError) $$
+                      maybe empty (\x -> "with value type" <+> ppType x) mt
+        ([],[(val,fun)]) -> do
+           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) 
+         (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
+ 
+checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
+    Abs bt x c -> do
+      case typ of
+        Prod bt' z a b -> do 
+        _ -> checkError $ "function type expected instead of" <+> ppType typ
+    AdHocOverload ts -> do
+        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
+    T _ [] ->
+      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
+    T _ cs -> case typ of 
+              else checkWarn ("patterns never reached:" $$
+                              nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
+      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
+    V arg0 vs ->
+              if length vs1 == length vs
+                 then return ()
+                 else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
+
+    R r -> case typ of --- why needed? because inference may be too difficult
+       RecType rr -> do
+       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
+
+    ExtR r s -> case typ of
+         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))
+
+             case typ2 of
+               RecType ss -> return $ map fst ss
+               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
+       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
+
+    S tab arg -> checks [ do
+        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
+
+    _ -> do
+      (trm',ty') <- inferLType gr g trm
+      termWith trm' $ checkEqLType gr g typ ty' trm'
+
+   checkM rms (l,ty) = case lookup l rms of
+     _ -> 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)
+
+checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
+    False -> checkError $ s <+> "type of" <+> ppTerm Unqualified 0 trm $$
+                          "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
+                          "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
+
+checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
+      Ok lo -> do
+        checkWarn $ "missing lock field" <+> fsep lo
+
+   missingLock g t u = case (t,u) of  
+         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
+
+
+
+pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
+    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
+              (length cont == length ps)
+  PR r -> do
+      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
+
+  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
+    
+   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 []
+
+checkLookup :: Ident -> Context -> Check Type -- used for looking up Vr x type in context
+    []     -> checkError ("unknown variable" <+> x)
+ 
+
+
+-------------------------------
+Grammar/Lookup.hs
+
+lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b
+    Bad _ -> raise ("unknown identifier" +++ showIdent c)
+
+lookupResDefLoc
+        _   -> raise $ render (c <+> "is not defined in resource" <+> m)
+
+lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
+    _   -> raise $ render (c <+> "has no type defined in resource" <+> m)
+
+lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
+    _            -> raise $ render (c <+> "has no types defined in resource" <+> m)
+
+lookupOverload :: ErrorMonad m => Grammar -> QIdent -> m [([Type],(Type,Term))]
+      _   -> raise $ render (c <+> "is not an overloaded operation")
+
+
+lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
+  case info of
+    ResParam _ (Just pvs) -> return pvs
+    _                     -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+
+
+allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
+    _ -> raise (render ("cannot find parameter values for" <+> ptyp))
+
+
+lookupFunType :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
+    _                           -> raise (render ("cannot find type of" <+> c))
+
+lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context
+    _                      -> raise (render ("unknown category" <+> c))
+
+
+-------------------------
+PatternMatch.hs
+
+matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
+  if not (isInConstantForm term)
+    then raise (render ("variables occur in" <+> pp term))
+
+findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
+   [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
+   (patts,_):_ | length patts /= length terms -> 
+       raise (render ("wrong number of args for patterns :" <+> hsep patts <+> 
+                    "cannot take" <+> hsep terms))
+
+tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
+      (PNeg p',_) -> case tryMatch (p',t) of
+        Bad _ -> return []
+        _ -> raise (render ("no match with negative pattern" <+> p))
+
+
+---------------------------------------------
+Compile.Optimize.hs
+
+mkLinDefault :: SourceGrammar -> Type -> Err Term
+                            _   -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p))
+     _ -> Bad (render ("linearization type field cannot be" <+> typ))
+
+mkLinReference :: SourceGrammar -> Type -> Err Term
+                            []     -> Bad "no string"
+
+
+---------------------------------------------
+Compile.Compute.Concrete.hs
+
+nfx env@(GE _ _ _ loc) t = do
+    Left i  -> fail ("variable #"++show i++" is out of scope")
+
+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)
+
+resource env (m,c) =
+  where e = fail $ "Not found: "++render m++"."++showIdent c
+
+extR t vv =
+      (VRecType rs1, VRecType rs2) ->
+          case intersect (map fst rs1) (map fst rs2) of
+            [] -> VRecType (rs1 ++ rs2)
+            ls -> error $ "clash"<+>show ls
+      (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
+                                         ppL loc (hang "unsupported token gluing:" 4
+                                                        (Glue (vt v1) (vt v2)))
+
+strsFromValue :: Value -> Err [Str]
+  _ -> fail ("cannot get Str from value " ++ show t)
+
+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: "++)
+
+    inlinePattMacro p =
+                        VPatt p' -> inlinePattMacro p'
+                        _ -> ppbug $ hang "Expected pattern macro:" 4
+
+linPattVars p =
+    if null dups
+    then return pvs
+    else fail.render $ hang "Pattern is not linear:" 4 (ppPatt Unqualified 0 p)
+
+---------------------------------------------
+Compile.Compute.Abstract.hs
+
+
+---------------------------------------------
+PGF.Linearize.hs
+
+bracketedLinearize :: PGF -> Language -> Tree -> [BracketedString]
+    cnc = lookMap (error "no lang") lang (concretes pgf)
+
+
+---------------------------------------------
+PGF.TypeCheck.hs
+
+ppTcError :: TcError -> Doc
+ppTcError (UnknownCat cat)             = text "Category" <+> ppCId cat <+> text "is not in scope"
+ppTcError (UnknownFun fun)             = text "Function" <+> ppCId fun <+> text "is not in scope"
+ppTcError (WrongCatArgs xs ty cat m n) = text "Category" <+> ppCId cat <+> text "should have" <+> int m <+> text "argument(s), but has been given" <+> int n $$
+                                         text "In the type:" <+> ppType 0 xs ty
+ppTcError (TypeMismatch xs e ty1 ty2)  = text "Couldn't match expected type" <+> ppType 0 xs ty1 $$
+                                         text "       against inferred type" <+> ppType 0 xs ty2 $$
+                                         text "In the expression:" <+> ppExpr 0 xs e
+ppTcError (NotFunType xs e ty)         = text "A function type is expected for the expression" <+> ppExpr 0 xs e <+> text "instead of type" <+> ppType 0 xs ty
+ppTcError (CannotInferType xs e)       = text "Cannot infer the type of expression" <+> ppExpr 0 xs e
+ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$
+                                         text "in the expression:" <+> ppExpr 0 xs e
+ppTcError (UnexpectedImplArg xs e)     = braces (ppExpr 0 xs e) <+> text "is implicit argument but not implicit argument is expected here"
+ppTcError (UnsolvableGoal xs metaid ty)= text "The goal:" <+> ppMeta metaid <+> colon <+> ppType 0 xs ty $$
+                                         text "cannot be solved"
+
--- a/doc/errors/gluing.md
+++ b/doc/errors/gluing.md
@@ -0,0 +1,27 @@
+## unsupported token gluing `foo + bar`
+
+There was a problem in an expression using +, e.g. `foo + bar`.
+This can be due to two causes, check which one applies in your case.
+
+1. You are trying to use + on runtime arguments. Even if you are using
+`foo + bar` in an oper, make sure that the oper isn't called in a
+linearization that takes arguments. Both of the following are illegal:
+
+    lin Test foo bar = foo.s + bar.s          -- explicit + in a lin
+    lin Test foo bar = opWithPlus foo bar     -- the oper uses +
+
+2. One of the arguments in `foo + bar` is a bound variable
+from pattern matching a string, but the cases are non-exhaustive.
+Example:
+    case "test" of {
+      x + "a" => x + "b"   -- no applicable case for "test", so x = ???
+    } ;
+
+You can fix this by adding a catch-all case in the end:
+    { x + "a" => x + "b" ;
+      _       => "default case" } ;
+
+3. If neither applies to your problem, submit a bug report and we
+will update the error message and this documentation.
+
+    https://github.com/GrammaticalFramework/gf-core/issues
--- a/doc/gf-developers-old-cabal.t2t
+++ b/doc/gf-developers-old-cabal.t2t
@@ -0,0 +1,201 @@
+GF Developer's Guide: Old installation instructions with Cabal
+
+
+This page contains the old installation instructions from the [Developer's Guide ../doc/gf-developers.html].
+We recommend Stack as a primary installation method, because it's easier for a Haskell beginner, and we want to keep the main instructions short.
+But if you are an experienced Haskeller and want to keep using Cabal, here are the old instructions using ``cabal install``.
+
+Note that some of these instructions may be outdated. Other parts may still be useful.
+
+== Compilation from source with Cabal ==
+
+The build system of GF is based on //Cabal//, which is part of the
+Haskell Platform, so no extra steps are needed to install it. In the simplest
+case, all you need to do to compile and install GF, after downloading the
+source code as described above, is
+
+```
+$ cabal install
+```
+
+This will automatically download any additional Haskell libraries needed to
+build GF. If this is the first time you use Cabal, you might need to run
+``cabal update`` first, to update the list of available libraries.
+
+If you want more control, the process can also be split up into the usual
+//configure//, //build// and //install// steps.
+
+=== Configure ===
+
+During the configuration phase Cabal will check that you have all
+necessary tools and libraries needed for GF. The configuration is
+started by the command:
+
+```
+$ cabal configure
+```
+
+If you don't see any error message from the above command then you
+have everything that is needed for GF. You can also add the option
+``-v`` to see more details about the configuration.
+
+You can use ``cabal configure --help`` to get a list of configuration options.
+
+=== Build ===
+
+The build phase does two things. First it builds the GF compiler from
+the Haskell source code and after that it builds the GF Resource Grammar
+Library using the already build compiler.  The simplest command is:
+
+```
+$ cabal build
+```
+
+Again you can add the option ``-v`` if you want to see more details.
+
+==== Parallel builds ====
+
+If you have Cabal>=1.20 you can enable parallel compilation by using
+
+```
+$ cabal build -j
+```
+
+or by putting a line
+```
+jobs: $ncpus
+```
+in your ``.cabal/config`` file. Cabal
+will pass this option to GHC when building the GF compiler, if you
+have GHC>=7.8.
+
+Cabal also passes ``-j`` to GF to enable parallel compilation of the
+Resource Grammar Library. This is done unconditionally to avoid
+causing problems for developers with Cabal<1.20. You can disable this
+by editing the last few lines in ``WebSetup.hs``.
+
+=== Install ===
+
+After you have compiled GF you need to install the executable and libraries
+to make the system usable.
+
+```
+$ cabal copy
+$ cabal register
+```
+
+This command installs the GF compiler for a single user, in the standard
+place used by Cabal.
+On Linux and Mac this could be ``$HOME/.cabal/bin``.
+On Mac it could also be ``$HOME/Library/Haskell/bin``.
+On Windows this is ``C:\Program Files\Haskell\bin``.
+
+The compiled GF Resource Grammar Library will be installed
+under the same prefix, e.g. in
+``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and
+in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows.
+
+If you want to install in some other place then use the ``--prefix``
+option during the configuration phase.
+
+=== Clean ===
+
+Sometimes you want to clean up the compilation and start again from clean
+sources. Use the clean command for this purpose:
+
+```
+$ cabal clean
+```
+
+
+%=== SDist ===
+%
+%You can use the command:
+%
+%% This does *NOT* include everything that is needed // TH 2012-08-06
+%```
+%$ cabal sdist
+%```
+%
+%to prepare archive with all source codes needed to compile GF.
+
+=== Known problems with Cabal ===
+
+Some versions of Cabal (at least version 1.16) seem to have a bug that can
+cause the following error:
+
+```
+Configuring gf-3.x...
+setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed
+```
+
+The exact cause of this problem is unclear, but it seems to happen
+during the configure phase if the same version of GF is already installed,
+so a workaround is to remove the existing installation with
+
+```
+ghc-pkg unregister gf
+```
+
+You can check with ``ghc-pkg list gf`` that it is gone.
+
+== Compilation with make ==
+
+If you feel more comfortable with Makefiles then there is a thin Makefile
+wrapper arround Cabal for you. If you just type:
+```
+$ make
+```
+the configuration phase will be run automatically if needed and after that
+the sources will be compiled.
+
+%% cabal build rgl-none does not work with recent versions of Cabal
+%If you don't want to compile the resource library
+%every time then you can use:
+%```
+%$ make gf
+%```
+
+For installation use:
+```
+$ make install
+```
+For cleaning:
+```
+$ make clean
+```
+%and to build source distribution archive run:
+%```
+%$ make sdist
+%```
+
+
+== Partial builds of RGL ==
+
+**NOTE**: The following doesn't work with recent versions of ``cabal``. //(This comment was left in 2015, so make your own conclusions.)//
+%% // TH 2015-06-22
+
+%Sometimes you just want to work on the GF compiler and don't want to
+%recompile the resource library after each change. In this case use
+%this extended command:
+
+%```
+%$ cabal build rgl-none
+%```
+
+The resource grammar library can be compiled in two modes: with present
+tense only and with all tenses. By default it is compiled with all
+tenses. If you want to use the library with only present tense you can
+compile it in this special mode with the command:
+
+```
+$ cabal build present
+```
+
+You could also control which languages you want to be recompiled by
+adding the option ``langs=list``. For example the following command
+will compile only the English and the Swedish language:
+
+```
+$ cabal build langs=Eng,Swe
+```
--- a/doc/gf-developers.t2t
+++ b/doc/gf-developers.t2t
@@ -1,6 +1,6 @@
 GF Developers Guide

-2018-07-26
+2021-07-15

 %!options(html): --toc

@@ -15,386 +15,287 @@ you are a GF user who just wants to download and install GF
 == Setting up your system for building GF ==

 To build GF from source you need to install some tools on your
-system: the //Haskell Platform//, //Git// and the //Haskeline library//.
+system: the Haskell build tool //Stack//, the version control software //Git// and the //Haskeline// library.

-**On Linux** the best option is to install the tools via the standard
-software distribution channels, i.e. by using the //Software Center//
-in Ubuntu or the corresponding tool in other popular Linux distributions.
-Or, from a Terminal window, the following command should be enough:
+%**On Linux** the best option is to install the tools via the standard
+%software distribution channels, i.e. by using the //Software Center//
+%in Ubuntu or the corresponding tool in other popular Linux distributions.

- On Ubuntu: ``sudo apt-get install haskell-platform git libghc6-haskeline-dev``
- On Fedora: ``sudo dnf install haskell-platform git ghc-haskeline-devel``
+%**On Mac OS and Windows**, the tools can be downloaded from their respective
+%web sites, as described below.
+
+=== Stack ===
+The primary installation method is via //Stack//.
+(You can also use Cabal, but we recommend Stack to those who are new to Haskell.)
+
+To install Stack:
+
+- **On Linux and Mac OS**, do either
+
+    ``$ curl -sSL https://get.haskellstack.org/ | sh``
+
+  or
+
+    ``$ wget -qO- https://get.haskellstack.org/ | sh``


-**On Mac OS and Windows**, the tools can be downloaded from their respective
-web sites, as described below.
+- **On other operating systems**, see the [installation guide https://docs.haskellstack.org/en/stable/install_and_upgrade].

-=== The Haskell Platform ===

-GF is written in Haskell, so first of all you need
-the //Haskell Platform//, e.g. version 8.0.2 or 7.10.3. Downloads
-and installation instructions are available from here:
+%If you already have Stack installed, upgrade it to the latest version by running: ``stack upgrade``

-    http://hackage.haskell.org/platform/
-
-Once you have installed the Haskell Platform, open a terminal
-(Command Prompt on Windows) and try to execute the following command:
-```
-$ ghc --version
-```
-This command should show you which version of GHC you have. If the installation
-of the Haskell Platform	 was successful you should see a message like:
-
-```
-The Glorious Glasgow Haskell Compilation System, version 8.0.2
-```
-
-Other required tools included in the Haskell Platform are
-[Cabal http://www.haskell.org/cabal/],
-[Alex http://www.haskell.org/alex/]
-and
-[Happy http://www.haskell.org/happy/].

 === Git ===

-To get the GF source code, you also need //Git//.
-//Git// is a distributed version control system, see
-https://git-scm.com/downloads for more information.
+To get the GF source code, you also need //Git//, a distributed version control system.

-=== The haskeline library ===
+- **On Linux**, the best option is to install the tools via the standard
+software distribution channels:
+
+  - On Ubuntu: ``sudo apt-get install git-all``
+  - On Fedora: ``sudo dnf install git-all``
+
+
+- **On other operating systems**, see
+https://git-scm.com/book/en/v2/Getting-Started-Installing-Git for installation.
+
+
+
+=== Haskeline ===

 GF uses //haskeline// to enable command line editing in the GF shell.
-This should work automatically on Mac OS and Windows, but on Linux one
-extra step is needed to make sure the C libraries (terminfo)
-required by //haskeline// are installed.  Here is one way to do this:

- On Ubuntu: ``sudo apt-get install libghc-haskeline-dev``
- On Fedora: ``sudo dnf install ghc-haskeline-devel``
+- **On Mac OS and Windows**, this should work automatically.
+
+- **On Linux**, an extra step is needed to make sure the C libraries (terminfo)
+required by //haskeline// are installed:
+
+  - On Ubuntu: ``sudo apt-get install libghc-haskeline-dev``
+  - On Fedora: ``sudo dnf install ghc-haskeline-devel``


-== Getting the source ==
+== Getting the source ==[getting-source]

-Once you have all tools in place you can get the GF source code. If you
-just want to compile and use GF then it is enough to have read-only
-access. It is also possible to make changes in the source code but if you
-want these changes to be applied back to the main source repository you will
-have to send the changes to us.  If you plan to work continuously on
-GF then you should consider getting read-write access.
+Once you have all tools in place you can get the GF source code from
+[GitHub https://github.com/GrammaticalFramework/]:

-=== Read-only access ===
+- https://github.com/GrammaticalFramework/gf-core for the GF compiler
+- https://github.com/GrammaticalFramework/gf-rgl for the Resource Grammar Library

-==== Getting a fresh copy for read-only access ====

-Anyone can get the latest development version of GF by running:
+=== Read-only access: clone the main repository ===
+
+If you only want to compile and use GF, you can just clone the repositories as follows:

 ```
-$ git clone https://github.com/GrammaticalFramework/gf-core.git
-$ git clone https://github.com/GrammaticalFramework/gf-rgl.git
+  $ git clone https://github.com/GrammaticalFramework/gf-core.git
+  $ git clone https://github.com/GrammaticalFramework/gf-rgl.git
 ```

-This will create directories ``gf-core`` and ``gf-rgl`` in the current directory.
-
-
-==== Updating your copy ====
-
-To get all new patches from each repo:
-```
-$ git pull
-```
-This can be done anywhere in your local repository.
-
-
-==== Recording local changes ====[record]
-
-Since every copy is a repository, you can have local version control
-of your changes.
-
-If you have added files, you first need to tell your local repository to
-keep them under revision control:
+To get new updates, run the following anywhere in your local copy of the repository:

 ```
-$ git add file1 file2 ...
+  $ git pull
 ```

-To record changes, use:
+=== Contribute your changes: fork the main repository ===
+
+If you want the possibility to contribute your changes,
+you should create your own fork, do your changes there,
+and then send a pull request to the main repository.
+
+ **Creating and cloning a fork  —**
+See GitHub documentation for instructions how to [create your own fork https://docs.github.com/en/get-started/quickstart/fork-a-repo]
+of the repository. Once you've done it, clone the fork to your local computer.

 ```
-$ git commit file1 file2 ...
+  $ git clone https://github.com/<YOUR_USERNAME>/gf-core.git
 ```

-This creates a patch against the previous version and stores it in your
-local repository. You can record any number of changes before
-pushing them to the main repo. In fact, you don't have to push them at
-all if you want to keep the changes only in your local repo.
-
-Instead of enumerating all modified files on the command line,
-you can use the flag ``-a`` to automatically record //all// modified
-files. You still need to use ``git add`` to add new files.
-
-
-=== Read-write access ===
-
-If you are a member of the GF project on GitHub, you can push your
-changes directly to the GF git repository on GitHub.
+ **Updating your copy —**
+Once you have cloned your fork, you need to set up the main repository as a remote:

 ```
-$ git push
+  $ git remote add upstream https://github.com/GrammaticalFramework/gf-core.git
 ```

-It is also possible for anyone else to contribute by
+Then you can get the latest updates by running the following:

- creating a fork of the GF repository on GitHub,
- working with local clone of the fork (obtained with ``git clone``),
- pushing changes to the fork,
- and finally sending a pull request.
+```
+  $ git pull upstream master
+```
+
+ **Recording local changes —**
+See Git tutorial on how to [record and push your changes https://git-scm.com/book/en/v2/Git-Basics-Recording-Changes-to-the-Repository] to your fork.
+
+ **Pull request —**
+When you want to contribute your changes to the main gf-core repository,
+[create a pull request https://docs.github.com/en/github/collaborating-with-pull-requests/proposing-changes-to-your-work-with-pull-requests/creating-a-pull-request]
+from your fork.



-== Compilation from source with Cabal ==
+If you want to contribute to the RGL as well, do the same process for the RGL repository.

-The build system of GF is based on //Cabal//, which is part of the
-Haskell Platform, so no extra steps are needed to install it. In the simplest
-case, all you need to do to compile and install GF, after downloading the
-source code as described above, is
+
+== Compilation from source ==
+
+By now you should have installed Stack and Haskeline, and cloned the Git repository on your own computer, in a directory called ``gf-core``.
+
+=== Primary recommendation: use Stack ===
+
+Open a terminal, go to the top directory (``gf-core``), and type the following command.
+
+```
+$ stack install
+```
+
+It will install GF and all necessary tools and libraries to do that.
+
+
+=== Alternative: use Cabal ===
+You can also install GF using Cabal, if you prefer Cabal to Stack. In that case, you may need to install some prerequisites yourself.
+
+The actual installation process is similar to Stack: open a terminal, go to the top directory (``gf-core``), and type the following command.

 ```
 $ cabal install
 ```

-This will automatically download any additional Haskell libraries needed to
-build GF. If this is the first time you use Cabal, you might need to run
-``cabal update`` first, to update the list of available libraries.
+//The old (potentially outdated) instructions for Cabal are moved to a [separate page ../doc/gf-developers-old-cabal.html]. If you run into trouble with ``cabal install``, you may want to take a look.//

-If you want more control, the process can also be split up into the usual
-//configure//, //build// and //install// steps.
+== Compiling GF with C runtime system support ==

-=== Configure ===
-
-During the configuration phase Cabal will check that you have all
-necessary tools and libraries needed for GF. The configuration is
-started by the command:
-
-```
-$ cabal configure
-```
-
-If you don't see any error message from the above command then you
-have everything that is needed for GF. You can also add the option
-``-v`` to see more details about the configuration.
-
-You can use ``cabal configure --help`` to get a list of configuration options.
-
-=== Build ===
-
-The build phase does two things. First it builds the GF compiler from
-the Haskell source code and after that it builds the GF Resource Grammar
-Library using the already build compiler.  The simplest command is:
-
-```
-$ cabal build
-```
-
-Again you can add the option ``-v`` if you want to see more details.
-
-==== Parallel builds ====
-
-If you have Cabal>=1.20 you can enable parallel compilation by using
-
-```
-$ cabal build -j
-```
-
-or by putting a line
-```
-jobs: $ncpus
-```
-in your ``.cabal/config`` file. Cabal
-will pass this option to GHC when building the GF compiler, if you
-have GHC>=7.8.
-
-Cabal also passes ``-j`` to GF to enable parallel compilation of the
-Resource Grammar Library. This is done unconditionally to avoid
-causing problems for developers with Cabal<1.20. You can disable this
-by editing the last few lines in ``WebSetup.hs``.
-
-
-==== Partial builds ====
-
-**NOTE**: The following doesn't work with recent versions of ``cabal``.
-%% // TH 2015-06-22
-
-Sometimes you just want to work on the GF compiler and don't want to
-recompile the resource library after each change. In this case use
-this extended command:
-
-```
-$ cabal build rgl-none
-```
-
-The resource library could also be compiled in two modes: with present
-tense only and with all tenses. By default it is compiled with all
-tenses. If you want to use the library with only present tense you can
-compile it in this special mode with the command:
-
-```
-$ cabal build present
-```
-
-You could also control which languages you want to be recompiled by
-adding the option ``langs=list``. For example the following command
-will compile only the English and the Swedish language:
-
-```
-$ cabal build langs=Eng,Swe
-```
-
-=== Install ===
-
-After you have compiled GF you need to install the executable and libraries
-to make the system usable.
-
-```
-$ cabal copy
-$ cabal register
-```
-
-This command installs the GF compiler for a single user, in the standard
-place used by Cabal.
-On Linux and Mac this could be ``$HOME/.cabal/bin``.
-On Mac it could also be ``$HOME/Library/Haskell/bin``.
-On Windows this is ``C:\Program Files\Haskell\bin``.
-
-The compiled GF Resource Grammar Library will be installed
-under the same prefix, e.g. in
-``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and
-in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows.
-
-If you want to install in some other place then use the ``--prefix``
-option during the configuration phase.
-
-=== Clean ===
-
-Sometimes you want to clean up the compilation and start again from clean
-sources. Use the clean command for this purpose:
-
-```
-$ cabal clean
-```
-
-
-%=== SDist ===
-%
-%You can use the command:
-%
-%% This does *NOT* include everything that is needed // TH 2012-08-06
-%```
-%$ cabal sdist
-%```
-%
-%to prepare archive with all source codes needed to compile GF.
-
-=== Known problems with Cabal ===
-
-Some versions of Cabal (at least version 1.16) seem to have a bug that can
-cause the following error:
-
-```
-Configuring gf-3.x...
-setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed
-```
-
-The exact cause of this problem is unclear, but it seems to happen
-during the configure phase if the same version of GF is already installed,
-so a workaround is to remove the existing installation with
-
-```
-ghc-pkg unregister gf
-```
-
-You can check with ``ghc-pkg list gf`` that it is gone.
-
-== Compilation with make ==
-
-If you feel more comfortable with Makefiles then there is a thin Makefile
-wrapper arround Cabal for you. If you just type:
-```
-$ make
-```
-the configuration phase will be run automatically if needed and after that
-the sources will be compiled.
-
-%% cabal build rgl-none does not work with recent versions of Cabal
-%If you don't want to compile the resource library
-%every time then you can use:
-%```
-%$ make gf
-%```
-
-For installation use:
-```
-$ make install
-```
-For cleaning:
-```
-$ make clean
-```
-%and to build source distribution archive run:
-%```
-%$ make sdist
-%```
-
-== Compiling GF with C run-time system support ==
-
-The C run-time system is a separate implementation of the PGF run-time services.
+The C runtime system is a separate implementation of the PGF runtime services.
 It makes it possible to work with very large, ambiguous grammars, using
-probabilistic models to obtain probable parses. The C run-time system might
-also be easier to use than the Haskell run-time system on certain platforms,
+probabilistic models to obtain probable parses. The C runtime system might
+also be easier to use than the Haskell runtime system on certain platforms,
 e.g. Android and iOS.

-To install the C run-time system, go to the ``src/runtime/c`` directory
-%and follow the instructions in the ``INSTALL`` file.
-and use the ``install.sh`` script:
-```
-bash setup.sh configure
-bash setup.sh build
-bash setup.sh install
-```
-This will install
-the C header files and libraries need to write C programs that use PGF grammars.
-Some example C programs are included in the ``utils`` subdirectory, e.g.
-``pgf-translate.c``.
+To install the C runtime system, go to the ``src/runtime/c`` directory.

-When the C run-time system is installed, you can install GF with C run-time
-support by doing
+- **On Linux and Mac OS —**
+  You should have autoconf, automake, libtool and make.
+  If you are missing some of them, follow the
+  instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file.
+
+  Once you have the required libraries, the easiest way to install the C runtime is to use the ``install.sh`` script. Just type
+
+  ``$ bash install.sh``
+
+  This will install the C header files and libraries need to write C programs
+  that use PGF grammars.
+
+%  If this doesn't work for you, follow the manual instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system.
+
+- **On other operating systems —** Follow the instructions in the
+[INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system.
+
+
+
+Depending on what you want to do with the C runtime, you can follow one or more of the following steps.
+
+=== Use the C runtime from another programming language ===[bindings]
+
+% **If you just want to use the C runtime from Python, Java, or Haskell, you don't need to change your GF installation.**
+
+- **What —**
+This is the most common use case for the C runtime: compile
+your GF grammars into PGF with the standard GF executable,
+and manipulate the PGFs from another programming language,
+using the bindings to the C runtime.
+
+
+- **How —**
+The Python, Java and Haskell bindings are found in the
+``src/runtime/{python,java,haskell-bind}`` directories,
+respecively. Compile them by following the instructions
+in the ``INSTALL`` or ``README`` files in those directories.
+
+The Python library can also be installed from PyPI using ``pip install pgf``.
+
+
+//If you are on Mac and get an error about ``clang`` version, you can try some of [these solutions https://stackoverflow.com/questions/63972113/big-sur-clang-invalid-version-error-due-to-macosx-deployment-target]—but be careful before removing any existing installations.//
+
+
+=== Use GF shell with C runtime support ===
+
+- **What —**
+If you want to use the GF shell with C runtime functionalities, then you need to (re)compile GF with special flags.
+
+The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use
+the C run-time system instead of the Haskell run-time system.
+Only limited functionality is available when running the shell in these
+modes (use the ``help`` command in the shell for details).
+
+(Re)compiling your GF with these flags will also give you
+Haskell bindings to the C runtime, as a library called ``PGF2``,
+but if you want Python or Java bindings, you need to do [the previous step #bindings].
+
+% ``PGF2``: a module to import in Haskell programs, providing a binding to the C run-time system.
+
+- **How —**
+If you use cabal, run the following command:

 ```
-cabal install -fserver -fc-runtime
+cabal install -fc-runtime
 ```
-from the top directory. This give you three new things:

- ``PGF2``: a module to import in Haskell programs, providing a binding to
-   the C run-time system.
+from the top directory (``gf-core``).

- The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use
-  the C run-time system instead of the Haskell run-time system.
-  Only limited functionality is available when running the shell in these
-  modes (use the ``help`` command in the shell for details).
+If you use stack, uncomment the following lines in the ``stack.yaml`` file:

- ``gf -server`` mode is extended with new requests to call the C run-time
-   system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``.
+```
+flags:
+   gf:
+     c-runtime: true
+extra-lib-dirs:
+   - /usr/local/lib
+```
+and then run ``stack install`` from the top directory (``gf-core``).


-=== Python and Java bindings ===
+//If you get an "``error while loading shared libraries``" when trying to run GF with C runtime, remember to declare your ``LD_LIBRARY_PATH``.//
+//Add ``export LD_LIBRARY_PATH="/usr/local/lib"`` to either your ``.bashrc`` or ``.profile``. You should now be able to start GF with C runtime.//
+
+
+=== Use GF server mode with C runtime ===
+
+- **What —**
+With this feature, ``gf -server`` mode is extended with new requests to call the C run-time
+system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``.
+
+- **How —**
+If you use cabal, run the following command:
+
+```
+cabal install -fc-runtime -fserver
+```
+from the top directory.
+
+If you use stack, add the following lines in the ``stack.yaml`` file:
+
+```
+flags:
+   gf:
+     c-runtime: true
+     server: true
+extra-lib-dirs:
+   - /usr/local/lib
+```
+
+and then run ``stack install``, also from the top directory.
+

-The C run-time system can also be used from Python and Java. Python and Java
-bindings are found in the ``src/runtime/python`` and ``src/runtime/java``
-directories, respecively. Compile them by following the instructions in
-the ``INSTALL`` files in those directories.

 == 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:
 ```
@@ -405,114 +306,79 @@ There is also ``make build``, ``make copy`` and ``make clean`` which do what you
 === Advanced ===
 For advanced build options, call the Haskell build script directly:
 ```
-$ runghc Make.hs ...
+$ runghc Setup.hs ...
 ```
 For more details see the [README https://github.com/GrammaticalFramework/gf-rgl/blob/master/README.md].

 === Haskell-free ===
-If you do not have Haskell installed, you can use the simple build script ``Make.sh``
-(or ``Make.bat`` for Windows).
+If you do not have Haskell installed, you can use the simple build script ``Setup.sh``
+(or ``Setup.bat`` for Windows).


 == Creating binary distribution packages ==

-=== Creating .deb packages for Ubuntu ===
+The binaries are generated with Github Actions. More details can be viewed here:

-This was tested on Ubuntu 14.04 for the release of GF 3.6, and the
-resulting ``.deb`` packages appears to work on Ubuntu 12.04, 13.10 and 14.04.
-For the release of GF 3.7, we generated ``.deb`` packages on Ubuntu 15.04 and
-tested them on Ubuntu 12.04 and 14.04.
+https://github.com/GrammaticalFramework/gf-core/actions/workflows/build-binary-packages.yml

-Under Ubuntu, Haskell executables are statically linked against other Haskell
-libraries, so the .deb packages are fairly self-contained.

-==== Preparations ====
+== Running the test suite ==
+
+The GF test suite is run with one of the following commands from the top directory:

 ```
-sudo apt-get install dpkg-dev debhelper
+  $ cabal test
 ```

-==== Creating the package ====
-
-Make sure the ``debian/changelog`` starts with an entry that describes the
-version you are building. Then run
+or

 ```
-make deb
+  $ stack test
 ```

-If get error messages about missing dependencies
-(e.g. ``autoconf``, ``automake``, ``libtool-bin``, ``python-dev``,
-``java-sdk``, ``txt2tags``)
-use ``apt-get intall`` to install them, then try again.
-
-
-=== Creating OS X Installer packages ===
-
-Run
-
-```
-make pkg
-```
-
-=== Creating binary tar distributions ===
-
-Run
-
-```
-make bintar
-```
-
-=== Creating .rpm packages for Fedora ===
-
-This is possible, but the procedure has not been automated.
-It involves using the cabal-rpm tool,
-
-```
-sudo dnf install cabal-rpm
-```
-
-and following the Fedora guide
-[How to create an RPM package http://fedoraproject.org/wiki/How_to_create_an_RPM_package].
-
-Under Fedora, Haskell executables are dynamically linked against other Haskell
-libraries, so ``.rpm`` packages for all Haskell libraries that GF depends on
-are required. Most of them are already available in the Fedora distribution,
-but a few of them might have to be built and distributed along with
-the GF ``.rpm`` package.
-When building ``.rpm`` packages for GF 3.4, we also had to build ``.rpm``s for
-``fst`` and ``httpd-shed``.
-
-== Running the testsuite ==
-
-**NOTE:** The test suite has not been maintained recently, so expect many
-tests to fail.
-%% // TH 2012-08-06
-
-GF has testsuite. It is run with the following command:
-```
-$ cabal test
-```
 The testsuite architecture for GF is very simple but still very flexible.
 GF by itself is an interpreter and could execute commands in batch mode.
 This is everything that we need to organize a testsuite. The root of the
-testsuite is the testsuite/ directory. It contains subdirectories which
-themself contain GF batch files (with extension .gfs). The above command
-searches the subdirectories of the testsuite/ directory for files with extension
-.gfs and when it finds one it is executed with the GF interpreter.
-The output of the script is stored in file with extension .out and is compared
-with the content of the corresponding file with extension .gold, if there is one.
-If the contents are identical the command reports that the test was passed successfully.
-Otherwise the test had failed.
+testsuite is the ``testsuite/`` directory. It contains subdirectories
+which themselves contain GF batch files (with extension ``.gfs``).
+The above command searches the subdirectories of the ``testsuite/`` directory
+for files with extension ``.gfs`` and when it finds one, it is executed with
+the GF interpreter. The output of the script is stored in file with extension ``.out``
+and is compared with the content of the corresponding file with extension ``.gold``, if there is one.

-Every time when you make some changes to GF that have to be tested, instead of
-writing the commands by hand in the GF shell, add them to one .gfs file in the testsuite
-and run the test. In this way you can use the same test later and we will be sure
-that we will not incidentaly break your code later.
+Every time when you make some changes to GF that have to be tested,
+instead of writing the commands by hand in the GF shell, add them to one ``.gfs``
+file in the testsuite subdirectory where its ``.gf`` file resides and run the test.
+In this way you can use the same test later and we will be sure that we will not
+accidentally break your code later.
+
+**Test Outcome - Passed:** If the contents of the files with the ``.out`` extension
+are identical to their correspondingly-named files with the extension ``.gold``,
+the command will report that the tests passed successfully, e.g.

-If you don't want to run the whole testsuite you can write the path to the subdirectory
-in which you are interested. For example:
 ```
-$ cabal test testsuite/compiler
+ Running 1 test suites...
+ Test suite gf-tests: RUNNING...
+ Test suite gf-tests: PASS
+ 1 of 1 test suites (1 of 1 test cases) passed.
 ```
-will run only the testsuite for the compiler.
+
+**Test Outcome - Failed:**  If there is a contents mismatch between the files
+with the ``.out`` extension and their corresponding files with the extension ``.gold``,
+the test diagnostics will show a fail and the areas that failed. e.g.
+
+```
+  testsuite/compiler/compute/Records.gfs: OK
+  testsuite/compiler/compute/Variants.gfs: FAIL
+  testsuite/compiler/params/params.gfs: OK
+  Test suite gf-tests: FAIL
+  0 of 1 test suites (0 of 1 test cases) passed.
+```
+
+The fail results overview is available in gf-tests.html which shows 4 columns:
+
+ __Results__ - only areas that fail will appear. (Note: There are 3 failures in the gf-tests.html which are labelled as (expected). These failures should be ignored.)
+ __Input__ - which is the test written in the .gfs file
+ __Gold__ - the expected output from running the test set out in the .gfs file. This column refers to the contents from the .gold extension files.
+ __Output__ - This column refers to the contents from the .out extension files which are generated as test output.
+After fixing the areas which fail, rerun the test command. Repeat the entire process of fix-and-test until the test suite passes before  submitting a pull request to include your changes.
--- a/doc/gf-editor-modes.t2t
+++ b/doc/gf-editor-modes.t2t
@@ -15,6 +15,13 @@ 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.
+- [Grammatical Framework https://marketplace.visualstudio.com/items?itemName=GrammaticalFramework.gf-vscode] is a simpler extension
+  without any external dependencies which provides only syntax highlighting.
+
 ==Eclipse==

 [GF Eclipse Plugin https://github.com/GrammaticalFramework/gf-eclipse-plugin/], by John J. Camilleri
--- a/doc/gf-people.md
+++ b/doc/gf-people.md
@@ -7,7 +7,6 @@ title: "Grammatical Framework: Authors and Acknowledgements"
 The current maintainers of GF are

 [Krasimir Angelov](http://www.chalmers.se/cse/EN/organization/divisions/computing-science/people/angelov-krasimir),
-[Thomas Hallgren](http://www.cse.chalmers.se/~hallgren/),
 [Aarne Ranta](http://www.cse.chalmers.se/~aarne/),
 [John J. Camilleri](http://johnjcamilleri.com), and
 [Inari Listenmaa](https://inariksit.github.io/).
@@ -22,6 +21,7 @@ and

 The following people have contributed code to some of the versions:

+- [Thomas Hallgren](http://www.cse.chalmers.se/~hallgren/) (University of Gothenburg)
 - Grégoire Détrez (University of Gothenburg)
 - Ramona Enache (University of Gothenburg)
 - [Björn Bringert](http://www.cse.chalmers.se/alumni/bringert) (University of Gothenburg)
@@ -32,6 +32,7 @@ The following people have contributed code to some of the versions:
 - [Janna Khegai](http://www.cs.chalmers.se/~janna) (Chalmers)
 - [Peter Ljunglöf](http://www.cse.chalmers.se/~peb) (University of Gothenburg)
 - Petri Mäenpää (Nokia)
+- Lauri Alanko (University of Helsinki)

 At least the following colleagues are thanked for suggestions, bug
 reports, and other indirect contributions to the code.
--- a/doc/gf-refman.html
+++ b/doc/gf-refman.html
--- a/doc/gf-refman.md
+++ b/doc/gf-refman.md
--- a/doc/gf-video-tutorials.md
+++ b/doc/gf-video-tutorials.md
@@ -0,0 +1,35 @@
+---
+title: "Video tutorials"
+---
+
+The GF [YouTube channel](https://www.youtube.com/channel/UCZ96DechSUVcXAhtOId9VVA) keeps a playlist of [all GF videos](https://www.youtube.com/playlist?list=PLrgqBB5thLeT15fUtJ8_Dtk8ppdtH90MK), and more specific playlists for narrower topics.
+If you make a video about GF, let us know and we'll add it to the suitable playlist(s)!
+
+- [General introduction to GF](#general-introduction-to-gf)
+- [Beginner resources](#beginner-resources)
+- [Resource grammar tutorials](#resource-grammar-tutorials)
+
+## General introduction to GF
+
+These videos introduce GF at a high level, and present some use cases.
+
+__Grammatical Framework: Formalizing the Grammars of the World__
+
+<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/x1LFbDQhbso" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>
+
+__Aarne Ranta: Automatic Translation for Consumers and Producers__
+
+<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/An-AmFScw1o" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>
+
+## Beginner resources
+
+These videos show how to install GF on your computer (Mac or Windows), and how to play with simple grammars in a [Jupyter notebook](https://github.com/GrammaticalFramework/gf-binder) (any platform, hosted at [mybinder.org](https://mybinder.org)).
+
+<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/videoseries?list=PLrgqBB5thLeRa8eViJJnjT8jBhxqCPMF2" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>
+
+## Resource grammar tutorials
+
+These videos show incremental improvements to a [miniature version of the resource grammar](https://github.com/inariksit/comp-syntax-2020/tree/master/lab2/grammar/dummy#readme).
+They assume some prior knowledge of GF, roughly lessons 1-3 from the [GF tutorial](http://www.grammaticalframework.org/doc/tutorial/gf-tutorial.html).
+
+<iframe width="560" height="315" src="https://www.youtube-nocookie.com/embed/videoseries?list=PLrgqBB5thLeTPkp88lnOmRtprCa8g0wX2" frameborder="0" allow="accelerometer; autoplay; encrypted-media; gyroscope; picture-in-picture" allowfullscreen></iframe>
--- a/doc/index.html
+++ b/doc/index.html
@@ -1,69 +0,0 @@
-<!DOCTYPE html>
-<html>
-<head>
-<title>GF Documentation</title>
-<link rel=stylesheet href="../css/style.css">
-</head>
- 
-
-<body>
-
-<div class=center>
-<a href="../"><img src="Logos/gf0.png"></a>
-
-
-
-
-<h1>Grammatical Framework Documents</h1>
-</div>
-
-
-<b>Top-5 documents</b>:
-
-<a href="gf-quickstart.html">Quick start instruction</a>.
-
-
-<a href="tutorial/gf-tutorial.html">Old Tutorial</a>, application-oriented.
-
-<a href="gf-lrec-2010.pdf">New Tutorial</a>, linguistics-oriented.
-
-<a href="gf-refman.html">ReferenceManual</a>.
-
-<a href="../lib/resource/doc/synopsis.html">LibrarySynopsis</a>.
-
-
-
-
-<h2>Language and system documentation</h2>
-
-<ul>
-
-  <li>
-  <a href="gf-reference.html">GF Quick Reference</a>. Also available in
-  <a href="gf-reference.pdf">pdf</a>. Covers all features of GF language
-  in a summary format.
-
-  <li>
-  <a href="gf-refman.html">GF Reference Manual</a>. A full-scale reference
-  manual of the GF language.
-  
-  <li>
-  <a href="gf-shell-reference.html">GF Shell Reference</a>.
-  Describes the commands available in the interactive GF shell. Also
-  summarizes how to run GF as a batch compiler.
-
-  <li>
-  <a href="gf-editor-modes.html">Editor modes for GF</a>.
-  Editor modes for GF provides syntax highligting, automatic indentation and
-  other features that makes editing GF grammar files easier.
-  
-</ul>
-
-
-<h2>Publications</h2>
-
-<a href="gf-bibliography.html">
-Bibliography</a>: more publications on GF, as well as background literature.
-
-
-</body></html>
--- a/doc/index.md
+++ b/doc/index.md
@@ -0,0 +1,13 @@
+---
+title: Grammatical Framework Documentation
+---
+
+Perhaps you're looking for one of the following:
+
+- [Tutorial](tutorial/gf-tutorial.html). This is a hands-on introduction to grammar writing in GF.
+- [Reference Manual](gf-refman.html). A full-scale reference manual of the GF language.
+- [RGL Tutorial](../lib/doc/rgl-tutorial/index.html)
+- [RGL Synopsis](../lib/doc/synopsis/index.html). Documentation of the Resource Grammar Library, including the syntax API and lexical paradigms for each language.
+- [Shell Reference](gf-shell-reference.html). Describes the commands available in the interactive GF shell.
+  Also summarizes how to run GF as a batch compiler.
+- [Developers Guide](gf-developers/html). Detailed information about building and developing GF.
--- a/doc/runtime-api.html
+++ b/doc/runtime-api.html
@@ -1,29 +1,26 @@
-<html>
+<!DOCTYPE html>
+<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
 	<head>
+		<title>C Runtime API</title>
+    <meta charset="utf-8" />
+    <meta name="viewport" content="width=device-width, initial-scale=1.0" />
+    <link rel="stylesheet" href="https://stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css" integrity="sha384-MCw98/SFnGE8fJT3GXwEOngsV7Zt27NXFoaoApmYm81iuXoPkFOJwJ8ERdknLPMO" crossorigin="anonymous">
 		<style>
-			body { background: #eee; padding-top: 200px; }
-
-			pre.python   {background-color:#ffc; display: none}
-			pre.haskell  {background-color:#ffc; display: block}
-			pre.java     {background-color:#ffc; display: none}
-			pre.csharp   {background-color:#ffc; display: none}
+			pre {
+				background-color:#eee;
+				margin-top: 1em;
+				padding: 0.5em 1em;
+			}
+			pre.python   {display: none}
+			pre.haskell  {display: block}
+			pre.java     {display: none}
+			pre.csharp   {display: none}
 			span.python  {display: none}
 			span.haskell {display: inline}
 			span.java    {display: none}
 			span.csharp  {display: none}
-			
-			.header {
-               position: fixed;
-               top: 0;
-               left: 0;
-               background: #ddd;
-               width: 100%;
-               padding: 5pt;
-               border-bottom: solid #bbb 2pt;
-            }
 		</style>

-
 <script lang="javascript">
 	function change_language(href) {
 		var name = href.split("#")[1];
@@ -50,14 +47,28 @@
 </script>
 	</head>
 	<body onload="change_language(window.location.href); window.addEventListener('hashchange', function(e){change_language(window.location.href);});">
-		<span class="header">
-		<h1>Using the <span class="python">Python</span> <span class="haskell">Haskell</span> <span class="java">Java</span> <span class="csharp">C#</span> binding to the C runtime</h1>
-		
-		Choose a language: <a href="#haskell">Haskell</a> <a href="#python">Python</a> <a href="#java">Java</a> <a href="#csharp">C#</a>
-		</span>
+		<div class="container-fluid" style="max-width: 1200px">
+		<div class="header sticky-top border-bottom py-3 bg-white">
+			<a href=".." title="Home">
+			  <img src="../doc/Logos/gf1.svg" height="120px" class="float-md-right ml-3 mb-3 bg-white" alt="GF Logo">
+			</a>
+			<h1>
+				Using the
+				<span class="python">Python</span>
+				<span class="haskell">Haskell</span>
+				<span class="java">Java</span>
+				<span class="csharp">C#</span>
+				binding to the C runtime
+			</h1>
+			<h4 class="text-muted">Krasimir Angelov, July 2015 - August 2017</h4>
+			Choose a language:
+			<a href="#haskell" class="mx-1">Haskell</a>
+			<a href="#python" class="mx-1">Python</a>
+			<a href="#java" class="mx-1">Java</a>
+			<a href="#csharp" class="mx-1">C#</a>
+		</div>
+		<main class="py-4">

-		<h4>Krasimir Angelov, July 2015 - August 2017</h4>
-		
 <h2>Loading the Grammar</h2>

 Before you use the <span class="python">Python</span> binding you need to import the <span class="haskell">PGF2 module</span><span class="python">pgf module</span><span class="java">pgf package</span><span class="csharp">PGFSharp package</span>:
@@ -127,7 +138,7 @@ Concr eng = gr.Languages["AppEng"];

 <h2>Parsing</h2>

-All language specific services are available as 
+All language specific services are available as
 <span class="python">methods of the class <tt>pgf.Concr</tt></span><span class="haskell">functions that take as an argument an object of type <tt>Concr</tt></span><span class="java">methods of the class <tt>Concr</tt></span><span class="csharp">methods of the class <tt>Concr</tt></span>.
 For example to invoke the parser, you can call:
 <pre class="python">
@@ -220,10 +231,10 @@ Console.WriteLine(ep.Item1);
 PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetNP (DetQuant this_Quant NumSg)) (UseComp (CompNP (DetCN (DetQuant IndefArt NumSg) (AdjCN (PositA small_A) (UseN theatre_N)))))))) NoVoc
 </pre>

-<p>Note that depending on the grammar it is absolutely possible that for 
-a single sentence you might get infinitely many trees. 
+<p>Note that depending on the grammar it is absolutely possible that for
+a single sentence you might get infinitely many trees.
 In other cases the number of trees might be finite but still enormous.
-The parser is specifically designed to be lazy, which means that 
+The parser is specifically designed to be lazy, which means that
 each tree is returned as soon as it is found before exhausting
 the full search space. For grammars with a patological number of
 trees it is advisable to pick only the top <tt>N</tt> trees
@@ -246,16 +257,16 @@ parsing with a different start category can be done as follows:</p>
 </pre>
 </span>
 <span class="haskell">
-There is also the function <tt>parseWithHeuristics</tt> which 
-takes two more paramaters which let you to have a better control 
+There is also the function <tt>parseWithHeuristics</tt> which
+takes two more paramaters which let you to have a better control
 over the parser's behaviour:
 <pre class="haskell">
 Prelude PGF2> let res = parseWithHeuristics eng (startCat gr) heuristic_factor callbacks
 </pre>
 </span>
 <span class="java">
-There is also the method <tt>parseWithHeuristics</tt> which 
-takes two more paramaters which let you to have a better control 
+There is also the method <tt>parseWithHeuristics</tt> which
+takes two more paramaters which let you to have a better control
 over the parser's behaviour:
 <pre class="java">
 Iterable&lt;ExprProb&gt; iterable = eng.parseWithHeuristics(gr.startCat(), heuristic_factor, callbacks);
@@ -281,7 +292,7 @@ to factor 0.0. When we increase the factor then parsing becomes faster
 but at the same time the sorting becomes imprecise. The worst
 factor is 1.0. In any case the parser always returns the same set of
 trees but in different order. Our experience is that even a factor
-of about 0.6-0.8 with the translation grammar still orders 
+of about 0.6-0.8 with the translation grammar still orders
 the most probable tree on top of the list but further down the list,
 the trees become shuffled.
 </p>
@@ -457,7 +468,7 @@ the object has the following public final variables:
 </span>
 </p>

-The linearization works even if there are functions in the tree 
+The linearization works even if there are functions in the tree
 that doesn't have linearization definitions. In that case you
 will just see the name of the function in the generated string.
 It is sometimes helpful to be able to see whether a function
@@ -483,7 +494,7 @@ true

 <p>
 An already constructed tree can be analyzed and transformed
-in the host application. For example you can deconstruct 
+in the host application. For example you can deconstruct
 a tree into a function name and a list of arguments:
 <pre class="python">
 >>> e.unpack()
@@ -523,8 +534,8 @@ literal. For example the result from:
 <span class="haskell">
 The result from <tt>unApp</tt> is <tt>Just</tt> if the expression
 is an application and <tt>Nothing</tt> in all other cases.
-Similarly, if the tree is a literal string then the return value 
-from <tt>unStr</tt> will be <tt>Just</tt> with the actual literal. 
+Similarly, if the tree is a literal string then the return value
+from <tt>unStr</tt> will be <tt>Just</tt> with the actual literal.
 For example the result from:
 </span>
 <pre class="haskell">
@@ -534,8 +545,8 @@ Prelude PGF2> readExpr "\"literal\"" >>= unStr
 <span class="java">
 The result from <tt>unApp</tt> is not <tt>null</tt> if the expression
 is an application, and <tt>null</tt> in all other cases.
-Similarly, if the tree is a literal string then the return value 
-from <tt>unStr</tt> will not be <tt>null</tt> with the actual literal. 
+Similarly, if the tree is a literal string then the return value
+from <tt>unStr</tt> will not be <tt>null</tt> with the actual literal.
 For example the output from:
 </span>
 <pre class="java">
@@ -545,15 +556,15 @@ System.out.println(elit.unStr());
 <span class="csharp">
 The result from <tt>UnApp</tt> is not <tt>null</tt> if the expression
 is an application, and <tt>null</tt> in all other cases.
-Similarly, if the tree is a literal string then the return value 
-from <tt>UnStr</tt> will not be <tt>null</tt> with the actual literal. 
+Similarly, if the tree is a literal string then the return value
+from <tt>UnStr</tt> will not be <tt>null</tt> with the actual literal.
 For example the output from:
 </span>
 <pre class="csharp">
 Expr elit = Expr.ReadExpr("\"literal\"");
 Console.WriteLine(elit.UnStr());
 </pre>
-is just the string "literal". 
+is just the string "literal".
 <span class="python">Situations like this can be detected
 in Python by checking the type of the result from <tt>unpack</tt>.
 It is also possible to get an integer or a floating point number
@@ -569,7 +580,7 @@ There are also the methods <tt>UnAbs</tt>, <tt>UnInt</tt>, <tt>UnFloat</tt> and
 </span>
 </p>

-Constructing new trees is also easy. You can either use 
+Constructing new trees is also easy. You can either use
 <tt>readExpr</tt> to read trees from strings, or you can
 construct new trees from existing pieces. This is possible by
 <span class="python">
@@ -612,7 +623,7 @@ Console.WriteLine(e2);
 <p>If the host application needs to do a lot of expression manipulations,
 then it is helpful to use a higher-level API to the grammar,
 also known as "embedded grammars" in GF. The advantage is that
-you can construct and analyze expressions in a more compact way.</p> 
+you can construct and analyze expressions in a more compact way.</p>

 <span class="python">
 <p>In Python you first have to <tt>embed</tt> the grammar by calling:
@@ -721,7 +732,7 @@ call the method <tt>default</tt>. The following is an example:
      def on_DetCN(self,quant,cn):
        print("Found DetCN")
        cn.visit(self)
-			
+
      def on_AdjCN(self,adj,cn):
        print("Found AdjCN")
        cn.visit(self)
@@ -1007,7 +1018,7 @@ Traceback (most recent call last):
 pgf.PGFError: The concrete syntax is not loaded
 </pre>

-Before using the concrete syntax, you need to explicitly load it: 
+Before using the concrete syntax, you need to explicitly load it:
 <pre class="python">
 >>> eng.load("AppEng.pgf_c")
 >>> print(eng.lookupMorpho("letter"))
@@ -1060,7 +1071,7 @@ Traceback (most recent call last):
 pgf.PGFError: The concrete syntax is not loaded
 </pre>

-Before using the concrete syntax, you need to explicitly load it: 
+Before using the concrete syntax, you need to explicitly load it:
 <pre class="java">
 eng.load("AppEng.pgf_c")
 for (MorphoAnalysis an : eng.lookupMorpho("letter")) {
@@ -1289,6 +1300,7 @@ graph {
 }
 </pre>

+		</main>
+		</div>
 	</body>
 </html>
-
--- a/doc/tutorial/gf-tutorial.t2t
+++ b/doc/tutorial/gf-tutorial.t2t
@@ -618,32 +618,32 @@ and **semantic definitions**.



-#NEW
-
-==Slides==
-
-You can chop this tutorial into a set of slides by the command
-```
-  htmls gf-tutorial.html
-```
-where the program ``htmls`` is distributed with GF (see below), in
-
-  [``GF/src/tools/Htmls.hs`` http://grammaticalframework.org/src/tools/Htmls.hs]
-
-The slides will appear as a set of files beginning with ``01-gf-tutorial.htmls``.
-
-Internal links will not work in the slide format, except for those in the
-upper left corner of each slide, and the links behind the "Contents" link.
+% #NEW
+%
+% ==Slides==
+%
+% You can chop this tutorial into a set of slides by the command
+% ```
+%   htmls gf-tutorial.html
+% ```
+% where the program ``htmls`` is distributed with GF (see below), in
+%
+%   [``GF/src/tools/Htmls.hs`` http://grammaticalframework.org/src/tools/Htmls.hs]
+%
+% The slides will appear as a set of files beginning with ``01-gf-tutorial.htmls``.
+%
+% Internal links will not work in the slide format, except for those in the
+% upper left corner of each slide, and the links behind the "Contents" link.



 #NEW

+#Lchaptwo
+
 =Lesson 1: Getting Started with GF=


-#Lchaptwo
-
 Goals:
 - install and run GF
 - write the first GF grammar: a "Hello World" grammar in three languages
@@ -898,7 +898,7 @@ Parentheses are only needed for grouping.
 Parsing something that is not in grammar will fail:
 ```
  > parse "hello dad"
-  Unknown words: dad
+  The parser failed at token 2: "dad"

  > parse "world hello"
  no tree found
@@ -1037,9 +1037,10 @@ Application programs, using techniques from #Rchapeight:

 #NEW

+#Lchapthree
+
 =Lesson 2: Designing a grammar for complex phrases=

-#Lchapthree

 Goals:
 - build a larger grammar: phrases about food in English and Italian
@@ -1797,9 +1798,10 @@ where

 #NEW

+#Lchapfour
+
 =Lesson 3: Grammars with parameters=

-#Lchapfour

 Goals:
 - implement sophisticated linguistic structures:
@@ -2473,7 +2475,7 @@ can be used to read a text and return for each word its analyses
 ```
 The command ``morpho_quiz = mq`` generates inflection exercises.
 ```
-  % gf -path=alltenses:prelude $GF_LIB_PATH/alltenses/IrregFre.gfo
+  % gf alltenses/IrregFre.gfo

  > morpho_quiz -cat=V

@@ -2486,11 +2488,6 @@ The command ``morpho_quiz = mq`` generates inflection exercises.
  réapparaîtriez
  Score 0/1
 ```
-To create a list for later use, use the command ``morpho_list = ml``
-```
-  > morpho_list -number=25 -cat=V | write_file exx.txt
-```
-



@@ -2649,12 +2646,12 @@ The verb //switch off// is called a

 We can define transitive verbs and their combinations as follows:
 ```
-  lincat TV = {s : Number => Str ; part : Str} ;
+  lincat V2 = {s : Number => Str ; part : Str} ;

-  fun AppTV : Item -> TV -> Item -> Phrase ;
+  fun AppV2 : Item -> V2 -> Item -> Phrase ;

-  lin AppTV subj tv obj =
-    {s = subj.s ++ tv.s ! subj.n ++ obj.s ++ tv.part} ;
+  lin AppV2 subj v2 obj =
+    {s = subj.s ++ v2.s ! subj.n ++ obj.s ++ v2.part} ;
 ```

 **Exercise**. Define the language ``a^n b^n c^n`` in GF, i.e.
@@ -2720,11 +2717,11 @@ This topic will be covered in #Rseclexing.

 The symbol ``**`` is used for both record types and record objects.
 ```
-  lincat TV = Verb ** {c : Case} ;
+  lincat V2 = Verb ** {c : Case} ;

  lin Follow = regVerb "folgen" ** {c = Dative} ;
 ```
-``TV`` becomes a **subtype** of ``Verb``.
+``V2`` (transitive verb) becomes a **subtype** of ``Verb``.

 If //T// is a subtype of //R//, an object of //T// can be used whenever
 an object of //R// is required.
@@ -2755,7 +2752,11 @@ Thus the labels ``p1, p2,...`` are hard-coded.
 English indefinite article:
 ```
  oper artIndef : Str =
-    pre {"a" ; "an" / strs {"a" ; "e" ; "i" ; "o"}} ;
+     pre {
+       ("a" | "e" | "i" | "o") => "an" ;
+       _ => "a"
+     } ;
+
 ```
 Thus
 ```
@@ -2772,9 +2773,10 @@ Thus

 #NEW

+#Lchapfive
+
 =Lesson 4: Using the resource grammar library=

-#Lchapfive

 Goals:
 - navigate in the GF resource grammar library and use it in applications
@@ -2945,7 +2947,7 @@ We need the following combinations:
 ```
 We also need **lexical insertion**, to form phrases from single words:
 ```
-  mkCN : N -> NP ;
+  mkCN : N -> CN ;
  mkAP : A -> AP ;
 ```
 Naming convention: to construct a //C//, use a function ``mk``//C//.
@@ -2966,7 +2968,7 @@ can be built as follows:
 ```
  mkCl
    (mkNP these_Det
-       (mkCN (mkAP very_AdA (mkAP warm_A)) (mkCN pizza_CN)))
+       (mkCN (mkAP very_AdA (mkAP warm_A)) (mkCN pizza_N)))
    (mkAP italian_AP)
 ```
 The task now: to define the concrete syntax of ``Foods`` so that
@@ -3614,9 +3616,10 @@ tenses and moods, e.g. the Romance languages.

 #NEW

+#Lchapsix
+
 =Lesson 5: Refining semantics in abstract syntax=

-#Lchapsix

 Goals:
 - include semantic conditions in grammars, by using
@@ -3714,49 +3717,25 @@ Concrete syntax does not know if a category is a dependent type.
 ```
 Notice that the ``Kind`` argument is suppressed in linearization.

-Parsing with dependent types is performed in two phases:
+Parsing with dependent types consists of two phases:
 + context-free parsing
 + filtering through type checker

+Parsing a type-correct command works as expected:

-By just doing the first phase, the ``kind`` argument is not found:
 ```
  > parse "dim the light"
-  CAction ? dim (DKindOne light)
-```
-Moreover, type-incorrect commands are not rejected:
-```
-  > parse "dim the fan"
-  CAction ? dim (DKindOne fan)
-```
-The term ``?`` is a **metavariable**, returned by the parser
-for any subtree that is suppressed by a linearization rule.
-These are the same kind of metavariables as were used #Rsecediting
-to mark incomplete parts of trees in the syntax editor.
-
-
-
-#NEW
-
-===Solving metavariables===
-
-Use the command ``put_tree = pt`` with the option ``-typecheck``:
-```
-  > parse "dim the light" | put_tree -typecheck
  CAction light dim (DKindOne light)
 ```
-The ``typecheck`` process may fail, in which case an error message
-is shown and no tree is returned:
+However, type-incorrect commands are rejected by the typecheck:
 ```
-  > parse "dim the fan" | put_tree -typecheck
-
-  Error in tree UCommand (CAction ? 0 dim (DKindOne fan)) :
-    (? 0 <> fan) (? 0 <> light)
+  > parse "dim the fan"
+  The parsing is successful but the type checking failed with error(s):
+    Couldn't match expected type Device light
+       against the interred type Device fan
+    In the expression: DKindOne fan       
 ```

-
-
-
 #NEW

 ==Polymorphism==
@@ -3782,23 +3761,19 @@ to express Haskell-type library functions:
    \_,_,_,f,x,y -> f y x ;
 ```

-
 #NEW

 ===Dependent types: exercises===

 1. Write an abstract syntax module with above contents
 and an appropriate English concrete syntax. Try to parse the commands
-//dim the light// and //dim the fan//, with and without ``solve`` filtering.
+//dim the light// and //dim the fan//.

-
-2. Perform random and exhaustive generation, with and without
-``solve`` filtering.
+2. Perform random and exhaustive generation.

 3. Add some device kinds and actions to the grammar.


-
 #NEW

 ==Proof objects==
@@ -3908,7 +3883,6 @@ fun
 Classes for new actions can be added incrementally.


-
 #NEW

 ==Variable bindings==
@@ -4177,11 +4151,11 @@ Type checking can be invoked with ``put_term -transform=solve``.

 #NEW

+#Lchapseven
+
 ==Lesson 6: Grammars of formal languages==


-#Lchapseven
-
 Goals:
 - write grammars for formal languages (mathematical notation, programming languages)
 - interface between formal and natural langauges
@@ -4196,7 +4170,8 @@ We construct a calculator with addition, subtraction, multiplication, and
 division of integers.
 ```
  abstract Calculator = {
-
+  flags startcat = Exp ;
+  
  cat Exp ;

  fun
@@ -4222,7 +4197,7 @@ We begin with a
 concrete syntax that always uses parentheses around binary
 operator applications:
 ```
-  concrete CalculatorP of Calculator = {
+  concrete CalculatorP of Calculator = open Prelude in {

  lincat
    Exp = SS ;
@@ -4516,9 +4491,10 @@ point literals as arguments.

 #NEW

+#Lchapeight
+
 =Lesson 7: Embedded grammars=

-#Lchapeight

 Goals:
 - use grammars as parts of programs written in Haskell and JavaScript
@@ -4732,10 +4708,6 @@ abstract Query = {

 To make it easy to define a transfer function, we export the
 abstract syntax to a system of Haskell datatypes:
-```
-  % gf --output-format=haskell Query.pgf
-```
-It is also possible to produce the Haskell file together with PGF, by
 ```
  % gf -make --output-format=haskell QueryEng.gf
 ```
@@ -4958,12 +4930,12 @@ syntax name. This file contains the multilingual grammar as a JavaScript object.
 ===Using the JavaScript grammar===

 To perform parsing and linearization, the run-time library
-``gflib.js`` is used. It is included in ``GF/lib/javascript/``, together with
+``gflib.js`` is used. It is included in ``/src/runtime/javascript/``, together with
 some other JavaScript and HTML files; these files can be used
 as templates for building applications.

 An example of usage is
-[``translator.html`` http://grammaticalframework.org:41296],
+[``translator.html`` ../../src/runtime/javascript/translator.html],
 which is in fact initialized with
 a pointer to the Food grammar, so that it provides translation between the English
 and Italian grammars:
--- a/download/gfc
+++ b/download/gfc
@@ -1,25 +0,0 @@
-#!/bin/sh
-
-prefix="/usr/local"
-
-case "i386-apple-darwin9.3.0" in
-      *-cygwin)
-          prefix=`cygpath -w "$prefix"`;;
-esac
-
-exec_prefix="${prefix}"
-GF_BIN_DIR="${exec_prefix}/bin"
-GF_DATA_DIR="${prefix}/share/GF-3.0-beta"
-
-GFBIN="$GF_BIN_DIR/gf"
-
-if [ ! -x "${GFBIN}" ]; then
-   GFBIN=`which gf`
-fi
-
-if [ ! -x "${GFBIN}" ]; then
-    echo "gf not found."
-    exit 1
-fi
-
-exec $GFBIN --batch "$@"
--- a/download/index-3.10.md
+++ b/download/index-3.10.md
@@ -3,22 +3,23 @@ title: Grammatical Framework Download and Installation
 ...

 **GF 3.10** was released on 2 December 2018.
-It is the first version of GF which _does not include the RGL_.

 What's new? See the [release notes](release-3.10.html).

 ## Binary packages

+These binary packages include both the GF core (compiler and runtime) as well as the pre-compiled RGL.
+
 | Platform        | Download                                           | Features       | How to install                     |
 |:----------------|:---------------------------------------------------|:---------------|:-----------------------------------|
 | macOS           | [gf-3.10.pkg](gf-3.10.pkg)                         | GF, S, C, J, P | Double-click on the package icon   |
-| Ubuntu (64-bit) | [gf\_3.10-1\_amd64.deb](gf_3.10-1_amd64.deb)       | GF, S, C, J, P | `sudo dpkg -i gf_3.10-1_amd64.deb` |
+| Raspbian 10 (buster) | [gf\_3.10-2\_armhf.deb](gf_3.10-2_armhf.deb)  | GF,S,C,J,P | `sudo dpkg -i gf_3.10-2_armhf.deb`     |
+| Ubuntu (32-bit) | [gf\_3.10-2\_i386.deb](gf_3.10-2_i386.deb)         | GF, S, C, J, P | `sudo dpkg -i gf_3.10-2_i386.deb`  |
+| Ubuntu (64-bit) | [gf\_3.10-2\_amd64.deb](gf_3.10-2_amd64.deb)       | GF, S, C, J, P | `sudo dpkg -i gf_3.10-2_amd64.deb` |
 | Windows         | [gf-3.10-bin-windows.zip](gf-3.10-bin-windows.zip) | GF, S          | `unzip gf-3.10-bin-windows.zip`    |

 <!--
 | macOS           | [gf-3.10-bin-intel-mac.tar.gz](gf-3.10-bin-intel-mac.tar.gz) | GF,S,C,J,P | `sudo tar -C /usr/local -zxf gf-3.10-bin-intel-mac.tar.gz` |
-| Raspbian 9.1     | [gf\_3.10-1\_armhf.deb](gf_3.10-1_armhf.deb)                 | GF,S,C,J,P | `sudo dpkg -i gf_3.10-1_armhf.deb`                         |
-| Ubuntu (32-bit) | [gf\_3.10-1\_i386.deb](gf_3.10-1_i386.deb)                   | GF,S,C,J,P | `sudo dpkg -i gf_3.10-1_i386.deb`                          |
 -->

 **Features**
@@ -35,7 +36,10 @@ probably need to set the `PATH` and `GF_LIB_PATH` environment variables,
 see Inari's notes on [Installing GF on Windows](http://www.grammaticalframework.org/~inari/gf-windows.html#toc3).

 The Ubuntu `.deb` packages should work on Ubuntu 16.04 and 18.04 and
-similar Linux distributions.
+similar Linux distributions. The `.deb` packages were updated
+to version 3.10-2 after the release of GF 3.10.
+(Because of a packaging bug the Resource Grammar Library was missing
+in the 3.10-1 packages.)

 <!-- The Raspbian `.deb` package was created on a Raspberry Pi 3 and will
 probably work on other ARM-based systems running Debian 9 (stretch) or
@@ -66,12 +70,10 @@ normal circumstances the procedure is fairly simple:
 3.  On Linux: install some C libraries from your Linux distribution (see note below)
 4.  `cabal install gf`

-Note that this installs GF _without_ the RGL.
+This installs the GF executable and Haskell libraries, but **does not include the RGL**.

-You can also download full source packages from GitHub at the following links:
-
- [GF releases](https://github.com/GrammaticalFramework/gf-core/releases)
- [RGL releases](https://github.com/GrammaticalFramework/gf-rgl/releases)
+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**.

 ### Notes

@@ -112,7 +114,7 @@ automatically by cabal, and therefore need to be installed manually.
 Here is one way to do this:

 - On Ubuntu: `sudo apt-get install libghc-haskeline-dev`
- On Fedora: `sudo yum install ghc-haskeline-devel`
+- On Fedora: `sudo dnf install ghc-haskeline-devel`

 **GHC version**

@@ -166,8 +168,23 @@ make
 ```

 in the RGL folder.
+This assumes that you already have GF installed.
 For more details about building the RGL, see the [RGL README](https://github.com/GrammaticalFramework/gf-rgl/blob/master/README.md).

+## Installing the Python bindings from PyPI
+
+The Python library is available on PyPI as `pgf`, so it can be installed using:
+
+```
+pip install pgf
+```
+
+We provide binary wheels for Linux and OSX (with Windows missing so far), which 
+include the C runtime and a ready-to-go.  If there is no binary distribution for
+your platform, this will install the source tarball, which will attempt to build 
+the binding during installation, and requires the GF C runtime to be installed on
+your system.
+
 ## Older releases

 - [GF 3.9](index-3.9.html) (August 2017)
--- a/download/index-3.11.md
+++ b/download/index-3.11.md
@@ -0,0 +1,192 @@
+---
+title: Grammatical Framework Download and Installation
+date: 25 July 2021
+---
+
+**GF 3.11** was released on 25 July 2021.
+
+What's new? See the [release notes](release-3.11.html).
+
+#### Note: GF core and the RGL
+
+The following instructions explain how to install **GF core**, i.e. the compiler, shell and run-time systems.
+Obtaining the **Resource Grammar Library (RGL)** is done separately; see the section at the bottom of this page.
+
+---
+
+## Installing from a binary package
+
+Binary packages are available for Debian/Ubuntu, macOS, and Windows and include:
+
+- GF shell and grammar compiler
+- `gf -server` mode
+- C run-time system
+- Java & Python bindings to the C run-time system
+
+Unlike in previous versions, the binaries **do not** include the RGL.
+
+[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 apt-get install ./gf-3.11-ubuntu-*.deb
+```
+
+<!-- The Ubuntu `.deb` packages should work on Ubuntu 16.04, 18.04 and similar Linux distributions. -->
+
+#### macOS
+
+To install the package, just double-click it and follow the installer instructions.
+
+The packages should work on at least Catalina and Big Sur.
+
+#### Windows
+
+To install the package, unpack it anywhere.
+
+You will probably need to update the `PATH` environment variable to include your chosen install location.
+
+For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10).
+
+## Installing from Hackage
+
+_Instructions applicable for 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:
+
+```
+cabal update
+cabal install gf-3.11
+```
+
+### Notes
+
+**GHC version**
+
+The GF source code is known to be compilable with GHC versions 7.10 through to 8.10.
+
+**Obtaining Haskell**
+
+There are various ways of obtaining Haskell, including:
+
+- ghcup
+    1.  Install from https://www.haskell.org/ghcup/
+    2.  `ghcup install ghc 8.10.4`
+    3.  `ghcup set ghc 8.10.4`
+- Haskell Platform https://www.haskell.org/platform/
+- Stack https://haskellstack.org/
+
+
+**Installation location**
+
+The above steps install GF for a single user.
+The executables are put in `$HOME/.cabal/bin` (or on macOS in `$HOME/Library/Haskell/bin`),
+so you might want to add this directory to your path (in `.bash_profile` or similar):
+
+```
+PATH=$HOME/.cabal/bin:$PATH
+```
+
+**Haskeline**
+
+GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which
+on Linux depends on some non-Haskell libraries that won't be installed
+automatically by Cabal, and therefore need to be installed manually.
+Here is one way to do this:
+
+- On Ubuntu: `sudo apt-get install libghc-haskeline-dev`
+- On Fedora: `sudo dnf install ghc-haskeline-devel`
+
+## Installing from source code
+
+**Obtaining**
+
+To obtain the source code for the **release**,
+download it from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases).
+
+Alternatively, to obtain the **latest version** of the source code:
+
+1. If you haven't already, clone the repository with:
+```
+git clone https://github.com/GrammaticalFramework/gf-core.git
+```
+2. If you've already cloned the repository previously, update with:
+```
+git pull
+```
+
+
+**Installing**
+
+You can then install with:
+```
+cabal install
+```
+
+or, if you're a Stack user:
+
+```
+stack install
+```
+
+<!--The above notes for installing from source apply also in these cases.-->
+For more info on working with the GF source code, see the
+[GF Developers Guide](../doc/gf-developers.html).
+
+## Installing the Python bindings from PyPI
+
+The Python library is available on PyPI as `pgf`, so it can be installed using:
+
+```
+pip install pgf
+```
+
+We provide binary wheels for Linux and macOS, which include the C runtime and are ready-to-go.
+If there is no binary distribution for your platform, this will install the source tarball,
+which will attempt to build the binding during installation,
+and requires the GF C runtime to be installed on your system.
+
+---
+
+## Installing the RGL from a binary release
+
+Binary releases of the RGL are made available on [GitHub](https://github.com/GrammaticalFramework/gf-rgl/releases).
+In general the steps to follow are:
+
+1. Download a binary release and extract it somewhere on your system.
+2. Set the environment variable `GF_LIB_PATH` to point to wherever you extracted the RGL.
+
+## Installing the RGL from source
+
+To compile the RGL, you will need to have GF already installed and in your path.
+
+1. Obtain the RGL source code, either by:
+  - cloning with `git clone https://github.com/GrammaticalFramework/gf-rgl.git`
+  - downloading a source archive [here](https://github.com/GrammaticalFramework/gf-rgl/archive/master.zip)
+2. Run `make` in the source code folder.
+
+For more options, see the [RGL README](https://github.com/GrammaticalFramework/gf-rgl/blob/master/README.md).
+
+---
+
+## Older releases
+
+- [GF 3.10](index-3.10.html) (December 2018)
+- [GF 3.9](index-3.9.html) (August 2017)
+- [GF 3.8](index-3.8.html) (June 2016)
+- [GF 3.7.1](index-3.7.1.html) (October 2015)
+- [GF 3.7](index-3.7.html) (June 2015)
+- [GF 3.6](index-3.6.html) (June 2014)
+- [GF 3.5](index-3.5.html) (August 2013)
+- [GF 3.4](index-3.4.html) (January 2013)
+- [GF 3.3.3](index-3.3.3.html) (March 2012)
+- [GF 3.3](index-3.3.html) (October 2011)
+- [GF 3.2.9](index-3.2.9.html) source-only snapshot (September 2011)
+- [GF 3.2](index-3.2.html) (December 2010)
+- [GF 3.1.6](index-3.1.6.html) (April 2010)
--- a/download/index.html
+++ b/download/index.html
@@ -0,0 +1,8 @@
+<html>
+<head>
+  <meta http-equiv="refresh" content="0; URL=/download/index-3.11.html" />
+</head>
+<body>
+  You are being redirected to <a href="index-3.11.html">the current version</a> of this page.
+</body>
+</html>
--- a/download/release-3.10.md
+++ b/download/release-3.10.md
@@ -9,8 +9,58 @@ See the [download page](index.html).

 ## What's new

- In this release, the GF "core" (compiler and runtimes) have been split from the RGL.
+In this release, the GF "core" (compiler and runtimes) and RGL have been split into separate repositories.
+The binary packages on the downloads page contain both GF and the RGL, but the sources are now separate:
+[gf-core](https://github.com/GrammaticalFramework/gf-core) and
+[gf-rgl](https://github.com/GrammaticalFramework/gf-rgl).

-### Other
+Over 300 changes have been pushed to GF and over 600 changes have been made to the RGL
+since the release of GF 3.9 in August 2017.

- A lot of repository cleanup
+## General
+
+- Travis integration:
+GF [![Build Status](https://travis-ci.org/GrammaticalFramework/gf-core.svg?branch=master)](https://travis-ci.org/GrammaticalFramework/gf-core) and
+RGL [![Build Status](https://travis-ci.org/GrammaticalFramework/gf-rgl.svg?branch=master)](https://travis-ci.org/GrammaticalFramework/gf-rgl)
+- A lot of bug fixes and repository cleanup, including things moved to new repositories:
+    - [Phrasebook](https://github.com/GrammaticalFramework/gf-contrib/tree/master/phrasebook)
+    - [Wide coverage translator](https://github.com/GrammaticalFramework/wide-coverage)
+    - [Mobile apps](https://github.com/GrammaticalFramework/gf-offline-translator)
+    - [gftest](https://github.com/GrammaticalFramework/gftest)
+    - [gf-mode](https://github.com/GrammaticalFramework/gf-emacs-mode) for Emacs
+    - [RGL browser](https://github.com/GrammaticalFramework/rgl-source-browser) (live [here](http://www.grammaticalframework.org/~john/rgl-browser/))
+- A fresh look for the GF website.
+
+## GF compiler and run-time library
+
+- Extensive improvements in the C runtime and bindings to it from Python, Java, Haskell, C#
+- A GF shell which uses the C runtime
+- Better error messages
+- GF now has a Stack configuration file
+- The compiler source code has been updated for compatibility with GHC 8.4.3.
+- `GF_LIB_PATH` can now be `path1:path2:path3`, not just `path1`
+- Add TypeScript type definitions for `gflib.js`
+- New compiler/shell options
+    - added option `-output-format=java` for producing code for embedded grammars in Java
+    - `rf -paragraphs`
+    - `linearize -tabtreebank`
+    - A new function called `completions` is added in the Haskell runtime and used in PGFService. This makes the extraction of completions more platform independent
+
+## Resource Grammar Library
+
+- [Bash build script](https://github.com/GrammaticalFramework/gf-rgl/blob/master/Setup.sh), for building the RGL without Haskell
+- [Windows build script](https://github.com/GrammaticalFramework/gf-rgl/blob/master/Setup.bat), for building the RGL without Haskell on a regular Windows command shell
+- New languages:
+    - Basque
+    - Portuguese
+- Big progress with Arabic, Turkish, Persian
+- Introduction of `Extend` module to combine the functions of `Extra` and `Extensions` in a more disciplined way
+- Various fixes for several languages.
+- Various fixes in the translation dictionaries.
+
+## Apps and Cloud services
+
+- Sort list of public grammars by age by default
+- Browser compatibility fixes
+- Allow public grammars to be deleted in more cases
+- Show grammar comments in the list of public grammars
--- a/download/release-3.11.md
+++ b/download/release-3.11.md
@@ -0,0 +1,43 @@
+---
+title: GF 3.11 Release Notes
+date: 25 July 2021
+---
+
+## Installation
+
+See the [download page](index-3.11.html).
+
+## What's new
+
+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 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.
+- Support for newer version of Ubuntu 20.04 in the precompiled binaries.
+- Updates to build scripts and CI workflows.
+- Bug fixes and code cleanup.
+
+## GF compiler and run-time library
+
+- 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.
+
+## Other
+
+- Web page and documentation improvements.
+- Add WordNet module to GFSE.
--- a/gf.cabal
+++ b/gf.cabal
@@ -1,19 +1,24 @@
 name: gf
-version: 3.10
+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/
+maintainer: John J. Camilleri <john@digitalgrammars.com>
+homepage: https://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-maintainer: Thomas Hallgren
-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4, GHC==9.0.2

 data-dir: src
+extra-source-files:
+  README.md
+  CHANGELOG.md
+  WebSetup.hs
+  doc/Logos/gf0.png
 data-files:
  www/*.html
  www/*.css
@@ -41,23 +46,23 @@ data-files:

 custom-setup
  setup-depends:
-    base,
-    Cabal >=1.22.0.0,
-    directory,
-    filepath,
-    process >=1.0.1.1
+    base >= 4.9.1 && < 4.16,
+    Cabal >= 1.22.0.0,
+    directory >= 1.3.0 && < 1.4,
+    filepath >= 1.4.1 && < 1.5,
+    process >= 1.0.1.1 && < 1.7

 source-repository head
-  type:     git
+  type: git
  location: https://github.com/GrammaticalFramework/gf-core.git

 flag interrupt
  Description: Enable Ctrl+Break in the shell
-  Default:     True
+  Default: True

 flag server
  Description: Include --server mode
-  Default:     True
+  Default: True

 flag network-uri
   description: Get Network.URI from the network-uri package
@@ -69,19 +74,29 @@ flag network-uri

 flag c-runtime
  Description: Include functionality from the C run-time library (which must be installed already)
-  Default:     False
+  Default: False
+
+library
+  default-language: Haskell2010
+  build-depends:
+    -- GHC 8.0.2 to GHC 8.10.4
+    array >= 0.5.1 && < 0.6,
+    base >= 4.9.1 && < 4.16,
+    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.1,
+    mtl >= 2.2.1 && < 2.3,
+    pretty >= 1.1.3 && < 1.2,
+    random >= 1.1 && < 1.3,
+    utf8-string >= 1.0.1.1 && < 1.1,
+    -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
+    transformers-compat >= 0.5.1.4 && < 0.7
+
+  if impl(ghc<8.0)
+    build-depends:
+      fail >= 4.9.0 && < 4.10

-Library
-  default-language:    Haskell2010
-  build-depends: base >= 4.6 && <5,
-                 array,
-                 containers,
-                 bytestring,
-                 utf8-string,
-                 random,
-                 pretty,
-                 mtl,
-                 exceptions
  hs-source-dirs: src/runtime/haskell

  other-modules:
@@ -96,8 +111,7 @@ Library
 --ghc-options: -fwarn-unused-imports
 --if impl(ghc>=7.8)
 --  ghc-options: +RTS -A20M -RTS
-  ghc-prof-options: -fprof-auto
-  extensions:
+  -- ghc-prof-options: -fprof-auto

  exposed-modules:
    PGF
@@ -131,18 +145,28 @@ Library

  if flag(c-runtime)
    exposed-modules: PGF2
-    other-modules:   PGF2.FFI PGF2.Expr PGF2.Type
-                     GF.Interactive2 GF.Command.Commands2
-    hs-source-dirs:  src/runtime/haskell-bind
-    build-tools:     hsc2hs
+    other-modules:
+      PGF2.FFI
+      PGF2.Expr
+      PGF2.Type
+      GF.Interactive2
+      GF.Command.Commands2
+    hs-source-dirs: src/runtime/haskell-bind
+    build-tools: hsc2hs
    extra-libraries: pgf gu
-    c-sources:       src/runtime/haskell-bind/utils.c
-    cc-options:      -std=c99
+    c-sources: src/runtime/haskell-bind/utils.c
+    cc-options: -std=c99

 ---- GF compiler as a library:

-  build-depends: filepath, directory, time, time-compat,
-                 process, haskeline, parallel>=3
+  build-depends:
+    directory >= 1.3.0 && < 1.4,
+    filepath >= 1.4.1 && < 1.5,
+    haskeline >= 0.7.3 && < 0.9,
+    json >= 0.9.1 && < 0.11,
+    parallel >= 3.2.1.1 && < 3.3,
+    process >= 1.4.3 && < 1.7,
+    time >= 1.6.0 && < 1.10

  hs-source-dirs: src/compiler
  exposed-modules:
@@ -150,14 +174,22 @@ Library
    GF.Support
    GF.Text.Pretty
    GF.Text.Lexing
+    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
@@ -172,9 +204,7 @@ Library
    GF.Command.TreeOperations
    GF.Compile.CFGtoPGF
    GF.Compile.CheckGrammar
-    GF.Compile.Compute.AppPredefined
-    GF.Compile.Compute.ConcreteNew
--  GF.Compile.Compute.ConcreteNew1
+    GF.Compile.Compute.Concrete
    GF.Compile.Compute.Predef
    GF.Compile.Compute.Value
    GF.Compile.ExampleBased
@@ -188,7 +218,10 @@ Library
    GF.Compile.PGFtoJava
    GF.Haskell
    GF.Compile.ConcreteToHaskell
+    GF.Compile.GrammarToCanonical
+    GF.Grammar.CanonicalJSON
    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
    GF.Compile.PGFtoProlog
    GF.Compile.PGFtoPython
    GF.Compile.ReadFiles
@@ -200,7 +233,6 @@ Library
    GF.Compile.TypeCheck.Concrete
    GF.Compile.TypeCheck.ConcreteNew
    GF.Compile.TypeCheck.Primitives
-    GF.Compile.TypeCheck.RConcrete
    GF.Compile.TypeCheck.TC
    GF.Compile.Update
    GF.Data.BacktrackM
@@ -267,12 +299,17 @@ Library
    cpp-options: -DC_RUNTIME

  if flag(server)
-    build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7, json,
-                   cgi>=3001.2.2.0
+    build-depends:
+      cgi >= 3001.3.0.2 && < 3001.6,
+      httpd-shed >= 0.4.0 && < 0.5,
+      network>=2.3 && <3.2
    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 && <3.2
    else
-      build-depends: network<2.6
+      build-depends:
+        network >= 2.5 && <3.2

    cpp-options: -DSERVER_MODE
    other-modules:
@@ -289,7 +326,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
@@ -298,26 +338,35 @@ Library
    other-modules: GF.System.NoSignal

  if impl(ghc>=7.8)
-    build-tools: happy>=1.19, alex>=3.1
+    build-tools:
+      happy>=1.19,
+      alex>=3.1
 --  ghc-options: +RTS -A20M -RTS
  else
-    build-tools: happy, alex>=3
+    build-tools:
+      happy,
+      alex>=3

  ghc-options: -fno-warn-tabs

  if os(windows)
-    build-depends: Win32
+    build-depends:
+      Win32 >= 2.3.1.1 && < 2.7
  else
-    build-depends: unix, terminfo>=0.4
+    build-depends:
+      terminfo >=0.4.0 && < 0.5,
+      unix >= 2.7.2 && < 2.8

  if impl(ghc>=8.2)
    ghc-options: -fhide-source-paths

-Executable gf
+executable gf
  hs-source-dirs: src/programs
  main-is: gf-main.hs
-  default-language:    Haskell2010
-  build-depends: gf, base
+  default-language: Haskell2010
+  build-depends:
+    gf,
+    base
  ghc-options: -threaded
 --ghc-options: -fwarn-unused-imports

@@ -326,24 +375,35 @@ Executable gf
    if impl(ghc<7.8)
      ghc-options: -with-rtsopts=-K64M

-  ghc-prof-options: -auto-all
+  -- ghc-prof-options: -auto-all

  if impl(ghc>=8.2)
    ghc-options: -fhide-source-paths

-executable pgf-shell
--if !flag(c-runtime)
-  buildable: False
-  main-is:             pgf-shell.hs
-  hs-source-dirs:      src/runtime/haskell-bind/examples
-  build-depends:       gf, base, containers, mtl, lifted-base
-  default-language:    Haskell2010
-  if impl(ghc>=7.0)
-    ghc-options: -rtsopts
+-- executable pgf-shell
+-- --if !flag(c-runtime)
+--   buildable: False
+--   main-is: pgf-shell.hs
+--   hs-source-dirs: src/runtime/haskell-bind/examples
+--   build-depends:
+--     gf,
+--     base,
+--     containers,
+--     mtl,
+--     lifted-base
+--   default-language: Haskell2010
+--   if impl(ghc>=7.0)
+--     ghc-options: -rtsopts

 test-suite gf-tests
-  type:           exitcode-stdio-1.0
-  main-is:        run.hs
+  type: exitcode-stdio-1.0
+  main-is: run.hs
  hs-source-dirs: testsuite
-  build-depends:  base>=4.3 && <5, Cabal>=1.8, directory, filepath, process
-  default-language:    Haskell2010
+  build-depends:
+    base >= 4.9.1 && < 4.16,
+    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
--- a/index.html
+++ b/index.html
@@ -8,7 +8,7 @@

  <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
  <link rel="stylesheet" href="https://stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css" integrity="sha384-MCw98/SFnGE8fJT3GXwEOngsV7Zt27NXFoaoApmYm81iuXoPkFOJwJ8ERdknLPMO" crossorigin="anonymous">
-  <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.4.2/css/all.css" integrity="sha384-/rXc/GQVaYpyDdyxK+ecHPVYJSN9bmVFBvjA/9eOB+pb3F2w2N6fc5qB9Ew5yIns" crossorigin="anonymous">
+  <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.15.4/css/all.css" crossorigin="anonymous">

  <link rel="alternate" href="https://github.com/GrammaticalFramework/gf-core/" title="GF GitHub repository">
 </head>
@@ -22,19 +22,24 @@
  <h4 class="text-black-50">A programming language for multilingual grammar applications</h4>
 </div>

-<div class="row my-4">
+<div class="row mt-4">

-  <div class="col-sm-6 col-md-3">
+  <div class="col-sm-6 col-md-3 mb-4">
    <h3>Get started</h3>
-    <ul>
+    <ul class="mb-2">
      <li><a href="https://www.youtube.com/watch?v=x1LFbDQhbso">Google Tech Talk</a></li>
      <li>
-        <a href="http://cloud.grammaticalframework.org/">
+        <a href="//cloud.grammaticalframework.org/">
          GF Cloud
-          <img src="http://www.grammaticalframework.org/src/www/P/gf-cloud.png" style="height:30px" class="ml-2">
+          <img src="src/www/P/gf-cloud.png" style="height:30px" class="ml-2" alt="Cloud logo">
        </a>
      </li>
-      <li><a href="doc/tutorial/gf-tutorial.html">Tutorial</a></li>
+      <li>
+        <a href="doc/tutorial/gf-tutorial.html">Tutorial</a>
+        /
+        <a href="lib/doc/rgl-tutorial/index.html">RGL Tutorial</a>
+      </li>
+      <li><a href="doc/gf-video-tutorials.html">Video Tutorials</a></li>
    </ul>

    <a href="download/index.html" class="btn btn-primary ml-3">
@@ -43,14 +48,15 @@
    </a>
  </div>

-  <div class="col-sm-6 col-md-3">
+  <div class="col-sm-6 col-md-3 mb-4">
    <h3>Learn more</h3>

-    <ul>
+    <ul class="mb-2">
      <li><a href="gf-book">The GF Book</a></li>
      <li><a href="doc/gf-refman.html">Reference Manual</a></li>
      <li><a href="doc/gf-shell-reference.html">Shell Reference</a></li>
      <li><a href="http://www.molto-project.eu/sites/default/files/MOLTO_D2.3.pdf">Best Practices</a> <small>[PDF]</small></li>
+      <li><a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Scaling Up (Computational Linguistics 2020)</a></li>
    </ul>

    <a href="lib/doc/synopsis/index.html" class="btn btn-primary ml-3">
@@ -59,27 +65,47 @@
    </a>
  </div>

-  <div class="col-sm-6 col-md-3">
+  <div class="col-sm-6 col-md-3 mb-4">
    <h3>Develop</h3>
-    <ul>
+    <ul class="mb-2">
      <li><a href="doc/gf-developers.html">Developers Guide</a></li>
      <!-- <li><a href="/~hallgren/gf-experiment/browse/">Browse Source Code</a></li> -->
-      <li><a href="http://hackage.haskell.org/package/gf/docs/PGF.html">PGF library API (Haskell runtime)</a></li>
-      <li><a href="doc/runtime-api.html">PGF library API (C runtime)</a></li>
+      <li>PGF library API:<br>
+        <a href="http://hackage.haskell.org/package/gf/docs/PGF.html">Haskell</a> /
+        <a href="doc/runtime-api.html">C&nbsp;runtime</a>
+      </li>
      <li><a href="http://hackage.haskell.org/package/gf/docs/GF.html">GF compiler API</a></li>
      <!-- <li><a href="src/ui/android/README">GF on Android (new)</a></li>
      <li><a href="/android/">GF on Android (old) </a></li> -->
      <li><a href="doc/gf-editor-modes.html">Text Editor Support</a></li>
+      <li><a href="http://www.grammaticalframework.org/~john/rgl-browser/">RGL source browser</a></li>
    </ul>
  </div>

-  <div class="col-sm-6 col-md-3">
+  <div class="col-sm-6 col-md-3 mb-4">
    <h3>Contribute</h3>
-    <ul>
-      <li><a href="http://groups.google.com/group/gf-dev">Mailing List</a></li>
+    <ul class="mb-2">
+      <li>
+        <a href="https://web.libera.chat/?channels=#gf">
+          <i class="fas fa-hashtag"></i>
+          IRC
+        </a>
+        /
+        <a href="https://discord.gg/EvfUsjzmaz">
+          <i class="fab fa-discord"></i>
+          Discord
+        </a>
+      </li>
+      <li>
+        <a href="https://stackoverflow.com/questions/tagged/gf">
+          <i class="fab fa-stack-overflow"></i>
+          Stack Overflow
+        </a>
+      </li>
+      <li><a href="https://groups.google.com/group/gf-dev">Mailing List</a></li>
      <li><a href="https://github.com/GrammaticalFramework/gf-core/issues">Issue Tracker</a></li>
+      <li><a href="//school.grammaticalframework.org/2020/">Summer School</a></li>
      <li><a href="doc/gf-people.html">Authors</a></li>
-      <li><a href="http://school.grammaticalframework.org/2018/">Summer School</a></li>
    </ul>
    <a href="https://github.com/GrammaticalFramework/" class="btn btn-primary ml-3">
      <i class="fab fa-github mr-1"></i>
@@ -145,12 +171,12 @@ least one, it may help you to get a first idea of what GF is.
 <div class="row">

  <div class="col-md-6">
-    <h2>Applications & Availability</h2>
+    <h2>Applications & availability</h2>
    <p>
    GF can be used for building
-    <a href="http://cloud.grammaticalframework.org/translator/">translation systems</a>,
-    <a href="http://cloud.grammaticalframework.org/minibar/minibar.html">multilingual web gadgets</a>,
-    <a href="http://www.cs.chalmers.se/~hallgren/Alfa/Tutorial/GFplugin.html">natural-language interfaces</a>,
+    <a href="//cloud.grammaticalframework.org/translator/">translation systems</a>,
+    <a href="//cloud.grammaticalframework.org/minibar/minibar.html">multilingual web gadgets</a>,
+    <a href="http://www.cse.chalmers.se/~hallgren/Alfa/Tutorial/GFplugin.html">natural-language interfaces</a>,
    <a href="http://www.youtube.com/watch?v=1bfaYHWS6zU">dialogue systems</a>, and
    <a href="lib/doc/synopsis/index.html">natural language resources</a>.
    </p>
@@ -165,6 +191,7 @@ least one, it may help you to get a first idea of what GF is.
    <li>macOS</li>
    <li>Windows</li>
    <li>Android mobile platform (via Java; runtime)</li>
+    <li>iOS mobile platform (iPhone, iPad)</li>
    <li>via compilation to JavaScript, almost any platform that has a web browser (runtime)</li>
    </ul>

@@ -204,44 +231,44 @@ 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.
-    IRC logs (in raw format) are available <a href="http://www.grammaticalframework.org/irc/">here</a>.
-    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>.
+    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://web.libera.chat/?channels=#gf">open a web chat</a>
+    or <a href="https://www.grammaticalframework.org/irc/?C=M;O=D">browse the channel logs</a>.
+    </p>
+    <p>
+    There is also a <a href="https://discord.gg/EvfUsjzmaz">GF server on Discord</a>.
+    </p>
+
+    <p>
+    For bug reports and feature requests, please create an issue in the
+    <a href="https://github.com/GrammaticalFramework/gf-core/issues">GF Core</a> or
+    <a href="https://github.com/GrammaticalFramework/gf-rgl/issues">RGL</a> repository.
+
+    For programming questions, consider asking them on <a href="https://stackoverflow.com/questions/tagged/gf">Stack Overflow with the <code>gf</code> tag</a>.
+    If you have a more general question to the community, we recommend you ask it on the <a href="http://groups.google.com/group/gf-dev">mailing list</a>.
    </p>

  </div>

  <div class="col-md-6">
    <h2>News</h2>
-
    <dl class="row">
-      <dt class="col-sm-3 text-center text-nowrap">2018-12-03</dt>
+      <dt class="col-sm-3 text-center text-nowrap">2021-07-25</dt>
      <dd class="col-sm-9">
-        <a href="http://school.grammaticalframework.org/2018/">Sixth GF Summer School</a> in Stellenbosch (South Africa), 3–14 December 2018
+        <strong>GF 3.11 released.</strong>
+        <a href="download/release-3.11.html">Release notes</a>
      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2018-12-02</dt>
+      <dt class="col-sm-3 text-center text-nowrap">2021-05-05</dt>
      <dd class="col-sm-9">
-        <strong>GF 3.10 released.</strong>
-        <!-- <a href="download/release-3.10.html">Release notes</a> -->
+        <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">2018-07-25</dt>
+      <dt class="col-sm-3 text-center text-nowrap">2021-03-01</dt>
      <dd class="col-sm-9">
-        The GF repository has been split in two:
-        <a href="https://github.com/GrammaticalFramework/gf-core">gf-core</a> and
-        <a href="https://github.com/GrammaticalFramework/gf-rgl">gf-rgl</a>.
-        The original <a href="https://github.com/GrammaticalFramework/GF">GF</a> repository is now archived.
+        <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">2017-08-11</dt>
+      <dt class="col-sm-3 text-center text-nowrap">2020-09-29</dt>
      <dd class="col-sm-9">
-        <strong>GF 3.9 released.</strong>
-        <a href="download/release-3.9.html">Release notes</a>
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-06-29</dt>
-      <dd class="col-sm-9">
-        GF is moving to <a href="https://github.com/GrammaticalFramework/GF/">GitHub</a>.</dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-03-13</dt>
-      <dd class="col-sm-9">
-        <a href="http://school.grammaticalframework.org/2017/">GF Summer School</a> in Riga (Latvia), 14-25 August 2017
+        <a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Abstract Syntax as Interlingua</a>: Scaling Up the Grammatical Framework from Controlled Languages to Robust Pipelines. A paper in Computational Linguistics (2020) summarizing much of the development in GF in the past ten years.
      </dd>
    </dl>

@@ -261,7 +288,7 @@ least one, it may help you to get a first idea of what GF is.
    </p>
    <ul>
    <li>
-      <a href="http://www.cs.chalmers.se/~hallgren/Alfa/Tutorial/GFplugin.html">GF-Alfa</a>:
+      <a href="http://www.cse.chalmers.se/~hallgren/Alfa/Tutorial/GFplugin.html">GF-Alfa</a>:
      natural language interface to formal proofs
    </li>
    <li>
@@ -286,11 +313,11 @@ least one, it may help you to get a first idea of what GF is.
      <a href="http://www.cse.chalmers.se/alumni/markus/FM/">Functional Morphology</a>
    </li>
    <li>
-      <a href="http://www.molto-project.eu">MOLTO</a>:
+      <a href="//www.molto-project.eu">MOLTO</a>:
      multilingual online translation
    </li>
    <li>
-      <a href="http://remu.grammaticalframework.org">REMU</a>:
+      <a href="//remu.grammaticalframework.org">REMU</a>:
      reliable multilingual digital communication
    </li>
    </ul>
@@ -312,14 +339,16 @@ least one, it may help you to get a first idea of what GF is.
    Libraries are at the heart of modern software engineering. In natural language
    applications, libraries are a way to cope with thousands of details involved in
    syntax, lexicon, and inflection. The
-    <a href="lib/doc/synopsis/index.html">GF resource grammar library</a> has
+    <a href="lib/doc/synopsis/index.html">GF resource grammar library</a> (RGL) has
    support for an increasing number of languages, currently including
    Afrikaans,
    Amharic (partial),
    Arabic (partial),
+    Basque (partial),
    Bulgarian,
    Catalan,
    Chinese,
+    Czech (partial),
    Danish,
    Dutch,
    English,
@@ -331,10 +360,12 @@ least one, it may help you to get a first idea of what GF is.
    Greek modern,
    Hebrew (fragments),
    Hindi,
+    Hungarian (partial),
    Interlingua,
-    Japanese,
    Italian,
-    Latin (fragments),
+    Japanese,
+    Korean (partial),
+    Latin (partial),
    Latvian,
    Maltese,
    Mongolian,
@@ -347,19 +378,22 @@ least one, it may help you to get a first idea of what GF is.
    Romanian,
    Russian,
    Sindhi,
+    Slovak (partial),
    Slovene (partial),
+    Somali (partial),
    Spanish,
    Swahili (fragments),
    Swedish,
    Thai,
    Turkish (fragments),
-    Urdu
+    and
+    Urdu.
    </p>

    <p>
    Adding a language to the resource library takes 3 to 9
    months - contributions
-    are welcome! You can start with the <a href="doc/gf-lrec-2010.pdf">resource grammarian's tutorial</a>.
+    are welcome! You can start with the <a href="lib/doc/rgl-tutorial/index.html">resource grammarian's tutorial</a>.
    </p>

  </div><!-- .col-6 -->
@@ -368,11 +402,14 @@ least one, it may help you to get a first idea of what GF is.

 </div><!-- .container -->

-<footer class="bg-light mt-5 py-5">
-  <div class="container mb-5">
-    <div class="row">
-    <div>
-  <div>
+<footer class="bg-light mt-5 py-4">
+  <div class="container mb-3">
+    <div class="text-center text-muted">
+      <img style="height:50px; filter: opacity(.5) grayscale(1);" class="mb-3" src="doc/Logos/gf0.svg" alt="GF Logo"><br>
+      Grammatical Framework is free and open source,<br>
+      with some support from <a href="https://www.digitalgrammars.com/">Digital Grammars AB</a>.
+    </div>
+  </div>
 </footer>

 <script type="text/javascript">
--- a/src/compiler/GF.hs
+++ b/src/compiler/GF.hs
@@ -19,7 +19,9 @@ module GF(
           module GF.Grammar.Printer,
           module GF.Infra.Ident,
           -- ** Binary serialisation
-           module GF.Grammar.Binary
+           module GF.Grammar.Binary,
+           -- * Canonical GF
+           module GF.Compile.GrammarToCanonical
  ) where
 import GF.Main
 import GF.Compiler
@@ -36,3 +38,5 @@ import GF.Grammar.Macros
 import GF.Grammar.Printer
 import GF.Infra.Ident
 import GF.Grammar.Binary
+
+import GF.Compile.GrammarToCanonical
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-}
 module GF.Command.Commands (
  PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
  options,flags,
  ) where
 import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+import System.Info(os)

 import PGF

@@ -34,6 +35,7 @@ import Data.Maybe
 import qualified Data.Map as Map
 import GF.Text.Pretty
 import Data.List (sort)
+import qualified Control.Monad.Fail as Fail
 --import Debug.Trace


@@ -44,7 +46,7 @@ pgfEnv pgf = Env pgf mos

 class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv

-instance (Monad m,HasPGFEnv m) => TypeCheckArg m where
+instance (Monad m,HasPGFEnv m,Fail.MonadFail m) => TypeCheckArg m where
  typeCheckArg e = (either (fail . render . ppTcError) (return . fst)
                    . flip inferExpr e . pgf) =<< getPGFEnv

@@ -740,7 +742,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))
@@ -881,11 +883,15 @@ pgfCommands = Map.fromList [
                       Right ty   -> ty
          Nothing -> error ("Can't parse '"++str++"' as a type")
   optViewFormat opts = valStrOpts "format" "png" opts
-   optViewGraph opts = valStrOpts "view" "open" opts
+   optViewGraph opts = valStrOpts "view" open_cmd opts
   optNum opts = valIntOpts "number" 1 opts
   optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
   takeOptNum opts = take (optNumInf opts)

+   open_cmd | os == "linux"   = "xdg-open"
+            | os == "mingw32" = "start"
+            | otherwise       = "open"
+
   returnFromExprs es = return $ case es of
     [] -> pipeMessage "no trees found"
     _  -> fromExprs es
@@ -1018,3 +1024,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
--- a/src/compiler/GF/Command/Commands2.hs
+++ b/src/compiler/GF/Command/Commands2.hs
@@ -18,6 +18,7 @@ import Data.Maybe
 import qualified Data.Map as Map
 import GF.Text.Pretty
 import Control.Monad(mplus)
+import qualified Control.Monad.Fail as Fail


 data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr}
@@ -25,7 +26,7 @@ data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr}
 pgfEnv pgf = Env (Just pgf) (languages pgf)
 emptyPGFEnv = Env Nothing Map.empty

-class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
+class (Fail.MonadFail m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv

 instance (Monad m,HasPGFEnv m) => TypeCheckArg m where
  typeCheckArg e = do env <- getPGFEnv
@@ -806,14 +807,22 @@ hsExpr c =
    Just (f,cs) -> H.mkApp (H.mkCId f) (map hsExpr cs)
    _ -> case unStr c of
           Just str -> H.mkStr str
-           _ -> error $ "GF.Command.Commands2.hsExpr "++show c
+           _ -> case unInt c of
+                  Just n -> H.mkInt n
+                  _ -> case unFloat c of
+                         Just d -> H.mkFloat d
+                         _ -> error $ "GF.Command.Commands2.hsExpr "++show c

 cExpr e =
  case H.unApp e of
    Just (f,es) -> mkApp (H.showCId f) (map cExpr es)
    _ -> case H.unStr e of
           Just str -> mkStr str
-           _ -> error $ "GF.Command.Commands2.cExpr "++show e
+           _ -> case H.unInt e of
+                  Just n -> mkInt n
+                  _ -> case H.unFloat e of
+                         Just d -> mkFloat d
+                         _ -> error $ "GF.Command.Commands2.cExpr "++show e

 needPGF exec opts ts =
  do Env mb_pgf cncs <- getPGFEnv
--- a/src/compiler/GF/Command/CommonCommands.hs
+++ b/src/compiler/GF/Command/CommonCommands.hs
@@ -15,6 +15,7 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
 import GF.Text.Pretty
 import GF.Text.Transliterations
 import GF.Text.Lexing(stringOp,opInEnv)
+import Data.Char (isSpace)

 import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))

@@ -170,7 +171,8 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
       restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
       fmap fromString $ restricted $ readFile tmpo,
       -}
-       fmap fromString . restricted . readShellProcess syst $ toString arg,
+       fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
+
     flags = [
       ("command","the system command applied to the argument")
       ],
--- a/src/compiler/GF/Command/Interpreter.hs
+++ b/src/compiler/GF/Command/Interpreter.hs
@@ -11,6 +11,8 @@ import GF.Infra.UseIO(putStrLnE)

 import Control.Monad(when)
 import qualified Data.Map as Map
+import GF.Infra.UseIO (Output)
+import qualified Control.Monad.Fail as Fail

 data CommandEnv m = CommandEnv {
  commands      :: Map.Map String (CommandInfo m),
@@ -22,6 +24,7 @@ data CommandEnv m = CommandEnv {
 mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty

 --interpretCommandLine :: CommandEnv -> String -> SIO ()
+interpretCommandLine :: (Fail.MonadFail m, Output m, TypeCheckArg m) => CommandEnv m -> String -> m ()
 interpretCommandLine env line =
  case readCommandLine line of
    Just []    -> return ()
--- a/src/compiler/GF/Command/SourceCommands.hs
+++ b/src/compiler/GF/Command/SourceCommands.hs
@@ -18,8 +18,8 @@ import GF.Grammar.Parser (runP, pExp)
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
-import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues)
-import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
+import GF.Compile.Compute.Concrete(normalForm,resourceValues)
+import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
 import GF.Infra.Dependencies(depGraph)
 import GF.Infra.CheckM(runCheck)

@@ -259,7 +259,7 @@ checkComputeTerm os sgr t =
     ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
                                inferLType sgr [] t
     let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-         t1 = CN.normalForm (CN.resourceValues opts sgr) (L NoLoc identW) t
+         t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
         t2 = evalStr t1
     checkPredefError t2
  where
--- a/src/compiler/GF/Compile/CFGtoPGF.hs
+++ b/src/compiler/GF/Compile/CFGtoPGF.hs
@@ -18,7 +18,7 @@ import Data.List
 --------------------------

 cf2pgf :: FilePath -> ParamCFG -> PGF
-cf2pgf fpath cf = 
+cf2pgf fpath cf =
 let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
 in updateProductionIndices pgf
 where
@@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats

    acats  = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
                            | (cat,rules) <- (Map.toList . Map.fromListWith (++))
-                                                [(cat2id cat, catRules cfg cat) | 
+                                                [(cat2id cat, catRules cfg cat) |
                                                     cat <- allCats' cfg]]
    afuns  = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
                            | rule <- allRules cfg]
@@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty
    cats  = allCats' cfg
    rules = allRules cfg

-    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : 
+    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
                               map mkSequence rules)
    sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)

@@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty

    mkLinDefRef (cat,_) =
      (cat2fid cat 0,[0])
-      
+
    addProd prods (fid,prod) =
      case IntMap.lookup fid prods of
        Just set -> IntMap.insert fid (Set.insert prod set) prods
@@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty

 mkRuleName rule =
  case ruleName rule of
-	CFObj n _ -> n
-	_         -> wildCId
+    CFObj n _ -> n
+    _         -> wildCId
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/11/11 23:24:33 $ 
+-- > CVS $Date: 2005/11/11 23:24:33 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.31 $
 --
@@ -27,21 +27,20 @@ import GF.Infra.Ident
 import GF.Infra.Option

 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.RConcrete
-import qualified GF.Compile.TypeCheck.ConcreteNew as CN
-import qualified GF.Compile.Compute.ConcreteNew as CN
+import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
+import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
+import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)

 import GF.Grammar
 import GF.Grammar.Lexer
 import GF.Grammar.Lookup
--import GF.Grammar.Predef
--import GF.Grammar.PatternMatch

 import GF.Data.Operations
 import GF.Infra.CheckM

 import Data.List
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Control.Monad
 import GF.Text.Pretty

@@ -59,7 +58,7 @@ checkModule opts cwd sgr mo@(m,mi) = do
  where
    updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
      where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
-    update mo@(m,mi) (i,info) = (m,mi{jments=updateTree (i,info) (jments mi)})
+    update mo@(m,mi) (i,info) = (m,mi{jments=Map.insert i info (jments mi)})

 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
@@ -72,12 +71,12 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
 where
   mos = modules sgr
   checkRem ((i,m),mi) = do
-     let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m)))
+     let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
     let incld c   = Set.member c (Set.fromList incl)
     let illegal c = Set.member c (Set.fromList excl)
-     let illegals = [(f,is) | 
+     let illegals = [(f,is) |
           (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
-     case illegals of 
+     case illegals of
       [] -> return ()
       cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
                         nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
@@ -89,16 +88,16 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
  let jsc = jments cnc

  -- check that all concrete constants are in abstract; build types for all lin
-  jsc <- foldM checkCnc emptyBinTree (tree2list jsc)
+  jsc <- foldM checkCnc Map.empty (Map.toList jsc)

  -- check that all abstract constants are in concrete; build default lin and lincats
-  jsc <- foldM checkAbs jsc (tree2list jsa)
-  
+  jsc <- foldM checkAbs jsc (Map.toList jsa)
+
  return (cm,cnc{jments=jsc})
  where
   checkAbs js i@(c,info) =
     case info of
-       AbsFun (Just (L loc ty)) _ _ _ 
+       AbsFun (Just (L loc ty)) _ _ _
           -> do let mb_def = do
                       let (cxt,(_,i),_) = typeForm ty
                       info <- lookupIdent i js
@@ -113,17 +112,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                 case lookupIdent c js of
                   Ok (AnyInd _ _) -> return js
                   Ok (CncFun ty (Just def) mn mf) ->
-                                 return $ updateTree (c,CncFun ty (Just def) mn mf) js
+                                 return $ Map.insert c (CncFun ty (Just def) mn mf) js
                   Ok (CncFun ty Nothing    mn mf) ->
                     case mb_def of
-                       Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
+                       Ok def -> return $ Map.insert c (CncFun ty (Just (L NoLoc def)) mn mf) js
                       Bad _  -> do noLinOf c
                                    return js
                   _ -> do
                     case mb_def of
                       Ok def -> do (cont,val) <- linTypeOfType gr cm ty
                                    let linty = (snd (valCat ty),cont,val)
-                                    return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
+                                    return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
                       Bad _  -> do noLinOf c
                                    return js
         where noLinOf c = checkWarn ("no linearization of" <+> c)
@@ -132,36 +131,42 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
         Ok (CncCat (Just _) _ _ _ _) -> return js
         Ok (CncCat Nothing md mr mp mpmcfg) -> do
           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
-           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
+           return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
         _ -> do
           checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
-           return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
+           return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
       _ -> return js
-     
-   checkCnc js i@(c,info) =
+
+   checkCnc js (c,info) =
     case info of
       CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> 
+                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
                                        do (cont,val) <- linTypeOfType gr cm ty
                                           let linty = (snd (valCat ty),cont,val)
-                                           return $ updateTree (c,CncFun (Just linty) d mn mf) js
+                                           return $ Map.insert c (CncFun (Just linty) d mn mf) js
                             _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
                                           return js
-       CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
-                             Ok _ -> return $ updateTree i js
-                             _    -> do checkWarn ("category" <+> c <+> "is not in abstract")
-                                        return js
-       _                -> return $ updateTree i js
+       CncCat {} ->
+         case lookupOrigInfo gr (am,c) of
+           Ok (_,AbsCat _) -> return $ Map.insert c info js
+           {- -- This might be too pedantic:
+           Ok (_,AbsFun {}) ->
+                   checkError ("lincat:"<+>c<+>"is a fun, not a cat")
+           -}
+           _ -> do checkWarn ("category" <+> c <+> "is not in abstract")
+                   return js
+
+       _ -> return $ Map.insert c info js


-- | General Principle: only Just-values are checked. 
+-- | General Principle: only Just-values are checked.
 -- A May-value has always been checked in its origin module.
 checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
 checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
  checkReservedId c
  case info of
-    AbsCat (Just (L loc cont)) -> 
-      mkCheck loc "the category" $ 
+    AbsCat (Just (L loc cont)) ->
+      mkCheck loc "the category" $
        checkContext gr cont

    AbsFun (Just (L loc typ0)) ma md moper -> do
@@ -170,13 +175,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
        checkTyp gr typ
      case md of
        Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
-	                                        checkDef gr (m,c) typ eq) eqs
+                                          checkDef gr (m,c) typ eq) eqs
        Nothing  -> return ()
      return (AbsFun (Just (L loc typ)) ma md moper)

    CncCat mty mdef mref mpr mpmcfg -> do
      mty  <- case mty of
-                Just (L loc typ) -> chIn loc "linearization type of" $ 
+                Just (L loc typ) -> chIn loc "linearization type of" $
                                     (if False --flag optNewComp opts
                                        then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
                                                typ  <- computeLType gr [] typ
@@ -186,19 +191,19 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
                                                return (Just (L loc typ)))
                Nothing          -> return Nothing
      mdef <- case (mty,mdef) of
-                (Just (L _ typ),Just (L loc def)) -> 
+                (Just (L _ typ),Just (L loc def)) ->
                    chIn loc "default linearization of" $ do
                       (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
                       return (Just (L loc def))
                _ -> return Nothing
      mref <- case (mty,mref) of
-                (Just (L _ typ),Just (L loc ref)) -> 
+                (Just (L _ typ),Just (L loc ref)) ->
                    chIn loc "reference linearization of" $ do
                       (ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
                       return (Just (L loc ref))
                _ -> return Nothing
      mpr  <- case mpr of
-                (Just (L loc t)) -> 
+                (Just (L loc t)) ->
                    chIn loc "print name of" $ do
                       (t,_) <- checkLType gr [] t typeStr
                       return (Just (L loc t))
@@ -207,13 +212,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do

    CncFun mty mt mpr mpmcfg -> do
      mt <- case (mty,mt) of
-              (Just (cat,cont,val),Just (L loc trm)) -> 
+              (Just (cat,cont,val),Just (L loc trm)) ->
                  chIn loc "linearization of" $ do
                     (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
                     return (Just (L loc trm))
              _ -> return mt
      mpr  <- case mpr of
-                (Just (L loc t)) -> 
+                (Just (L loc t)) ->
                    chIn loc "print name of" $ do
                       (t,_) <- checkLType gr [] t typeStr
                       return (Just (L loc t))
@@ -246,16 +251,16 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
    ResOverload os tysts -> chIn NoLoc "overloading" $ do
      tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
      tysts0 <- lookupOverload gr (m,c)  -- check against inherited ones too
-      tysts1 <- mapM (uncurry $ flip (checkLType gr [])) 
+      tysts1 <- mapM (uncurry $ flip (checkLType gr []))
                  [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
      --- this can only be a partial guarantee, since matching
      --- with value type is only possible if expected type is given
-      checkUniq $ 
+      checkUniq $
        sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
      return (ResOverload os [(y,x) | (x,y) <- tysts'])

    ResParam (Just (L loc pcs)) _ -> do
-      ts <- chIn loc "parameter type" $ 
+      ts <- chIn loc "parameter type" $
              liftM concat $ mapM mkPar pcs
      return (ResParam (Just (L loc pcs)) (Just ts))

@@ -265,13 +270,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
   chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)

   mkPar (f,co) = do
-       vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+       vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
       return $ map (mkApp (QC (m,f))) vs

   checkUniq xss = case xss of
-     x:y:xs 
+     x:y:xs
      | x == y    -> checkError $ "ambiguous for type" <+>
-                                  ppType (mkFunType (tail x) (head x))  
+                                  ppType (mkFunType (tail x) (head x))
      | otherwise -> checkUniq $ y:xs
     _ -> return ()

@@ -289,7 +294,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
       t' <- compAbsTyp ((x,Vr x):g) t
       return $ Prod b x a' t'
     Abs _ _ _ -> return t
-     _ -> composOp (compAbsTyp g) t  
+     _ -> composOp (compAbsTyp g) t


 -- | for grammars obtained otherwise than by parsing ---- update!!
@@ -311,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 $$
--- a/src/compiler/GF/Compile/Coding.hs
+++ b/src/compiler/GF/Compile/Coding.hs
@@ -1,64 +0,0 @@
-module GF.Compile.Coding where
-{-
-import GF.Grammar.Grammar
-import GF.Grammar.Macros
-import GF.Text.Coding
--import GF.Infra.Option
-import GF.Data.Operations
-
--import Data.Char
-import System.IO
-import qualified Data.ByteString.Char8 as BS
-
-encodeStringsInModule :: TextEncoding -> SourceModule -> SourceModule
-encodeStringsInModule enc = codeSourceModule (BS.unpack . encodeUnicode enc)
-
-decodeStringsInModule :: TextEncoding -> SourceModule -> SourceModule
-decodeStringsInModule enc mo = codeSourceModule (decodeUnicode enc . BS.pack) mo
-
-codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
-codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
- where
-    codj (c,info) = case info of
-      ResOper     pty pt   -> ResOper (codeLTerms co pty) (codeLTerms co pt) 
-      ResOverload es tyts  -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
-      CncCat mcat mdef mref mpr mpmcfg -> CncCat mcat (codeLTerms co mdef) (codeLTerms co mref) (codeLTerms co mpr) mpmcfg
-      CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
-      _ -> info
-
-codeLTerms co = fmap (codeLTerm co)
-
-codeLTerm :: (String -> String) -> L Term -> L Term
-codeLTerm = fmap . codeTerm
-
-codeTerm :: (String -> String) -> Term -> Term
-codeTerm co = codt
-  where
-    codt t = case t of
-      K s -> K (co s)
-      T ty cs -> T ty [(codp p,codt v) | (p,v) <- cs]
-      EPatt p -> EPatt (codp p)
-      _ -> composSafeOp codt t
-
-    codp p = case p of  --- really: composOpPatt
-      PR rs -> PR [(l,codp p) | (l,p) <- rs]
-      PString s -> PString (co s)
-      PChars s -> PChars (co s)
-      PT x p -> PT x (codp p)
-      PAs x p -> PAs x (codp p)
-      PNeg p -> PNeg (codp p)
-      PRep p -> PRep (codp p)
-      PSeq p q -> PSeq (codp p) (codp q)
-      PAlt p q -> PAlt (codp p) (codp q)
-      _ -> p
-
-- | Run an encoding function on all string literals within the given string.
-codeStringLiterals :: (String -> String) -> String -> String
-codeStringLiterals _ [] = []
-codeStringLiterals co ('"':cs) = '"' : inStringLiteral cs
-  where inStringLiteral [] = error "codeStringLiterals: unterminated string literal"
-        inStringLiteral ('"':ds) = '"' : codeStringLiterals co ds
-        inStringLiteral ('\\':d:ds) = '\\' : co [d] ++ inStringLiteral ds
-        inStringLiteral (d:ds) = co [d] ++ inStringLiteral ds
-codeStringLiterals co (c:cs) = c : codeStringLiterals co cs
-}
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs
@@ -1,143 +0,0 @@
----------------------------------------------------------------------
-- |
-- Module      : AppPredefined
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/10/06 14:21:34 $ 
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.13 $
--
-- Predefined function type signatures and definitions.
-----------------------------------------------------------------------------
-
-module GF.Compile.Compute.AppPredefined ({-
-          isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined-}
-		  ) where
-{-
-import GF.Compile.TypeCheck.Primitives
-import GF.Infra.Option
-import GF.Data.Operations
-import GF.Grammar
-import GF.Grammar.Predef
-
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import Data.Char (isUpper,toUpper,toLower)
-
-- predefined function type signatures and definitions. AR 12/3/2003.
-
-isInPredefined :: Ident -> Bool
-isInPredefined f = Map.member f primitives
-
-arrityPredefined :: Ident -> Maybe Int
-arrityPredefined f = do ty <- typPredefined f
-                        let (ctxt,_) = typeFormCnc ty
-                        return (length ctxt)
-
-predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
-
-appPredefined :: Term -> Err (Term,Bool)
-appPredefined t = case t of
-  App f x0 -> do
-   (x,_) <- appPredefined x0
-   case f of
-    -- one-place functions
-    Q (mod,f) | mod == cPredef ->
-      case x of
-        (K s) | f == cLength  -> retb $ EInt $ length s
-        (K s) | f == cIsUpper -> retb $ if (all isUpper s) then predefTrue else predefFalse
-        (K s) | f == cToUpper -> retb $ K $ map toUpper s
-        (K s) | f == cToLower -> retb $ K $ map toLower s
-        (K s) | f == cError   -> retb $ Error s
-
-        _                    -> retb t
-
-    -- two-place functions
-    App (Q (mod,f)) z0 | mod == cPredef -> do
-     (z,_) <- appPredefined z0
-     case (norm z, norm x) of
-      (EInt i, K s)    | f == cDrop    -> retb $ K (drop i s)
-      (EInt i, K s)    | f == cTake    -> retb $ K (take i s)
-      (EInt i, K s)    | f == cTk      -> retb $ K (take (max 0 (length s - i)) s)
-      (EInt i, K s)    | f == cDp      -> retb $ K (drop (max 0 (length s - i)) s)
-      (K s,    K t)    | f == cEqStr   -> retb $ if s == t then predefTrue else predefFalse
-      (K s,    K t)    | f == cOccur   -> retb $ if substring s t then predefTrue else predefFalse
-      (K s,    K t)    | f == cOccurs  -> retb $ if any (flip elem t) s then predefTrue else predefFalse
-      (EInt i, EInt j) | f == cEqInt   -> retb $ if i==j then predefTrue else predefFalse
-      (EInt i, EInt j) | f == cLessInt -> retb $ if i<j  then predefTrue else predefFalse
-      (EInt i, EInt j) | f == cPlus    -> retb $ EInt $ i+j
-      (_,      t)      | f == cShow  && notVar t  -> retb $ foldrC $ map K $ words $ render (ppTerm Unqualified 0 t)
-      (_,      K s)    | f == cRead    -> retb $ Cn (identS s) --- because of K, only works for atomic tags
-      (_,      t)      | f == cToStr   -> trm2str t >>= retb
-      _ -> retb t ---- prtBad "cannot compute predefined" t
-
-    -- three-place functions
-    App (App (Q (mod,f)) z0) y0 | mod == cPredef -> do
-     (y,_) <- appPredefined y0
-     (z,_) <- appPredefined z0
-     case (z, y, x) of
-       (ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
-       _ | f == cEqVal && notVar y && notVar x -> retb $ if y==x then predefTrue else predefFalse
-       _ -> retb t ---- prtBad "cannot compute predefined" t
-
-    _ -> retb t ---- prtBad "cannot compute predefined" t
-  _ -> retb t
-                  ---- should really check the absence of arg variables
- where
-   retb t = return (retc t,True)  -- no further computing needed
-   retf t = return (retc t,False) -- must be computed further
-   retc t = case t of
-     K [] -> t
-     K s  -> foldr1 C (map K (words s))
-     _    -> t
-   norm t = case t of
-     Empty -> K []
-     C u v -> case (norm u,norm v) of
-       (K x,K y) -> K (x +++ y)
-       _ -> t
-     _ -> t
-   notVar t = case t of
-     Vr _ -> False
-     App f a -> notVar f && notVar a
-     _ -> True ---- would need to check that t is a value
-   foldrC ts = if null ts then Empty else foldr1 C ts
-
-- read makes variables into constants
-
-predefTrue = QC (cPredef,cPTrue)
-predefFalse = QC (cPredef,cPFalse)
-
-substring :: String -> String -> Bool
-substring s t = case (s,t) of
-  (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
-  ([],_) -> True
-  _ -> False
-
-trm2str :: Term -> Err Term
-trm2str t = case t of
-  R ((_,(_,s)):_) -> trm2str s
-  T _ ((_,s):_)   -> trm2str s
-  V _ (s:_)       -> trm2str s
-  C _ _           -> return $ t
-  K _             -> return $ t
-  S c _           -> trm2str c
-  Empty           -> return $ t
-  _               -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-
-- simultaneous recursion on type and term: type arg is essential!
-- But simplify the task by assuming records are type-annotated
-- (this has been done in type checking)
-mapStr :: Type -> Term -> Term -> Term
-mapStr ty f t = case (ty,t) of
-  _ | elem ty [typeStr,typeTok] -> App f t
-  (_,        R ts)    -> R [(l,mapField v)   | (l,v) <- ts]
-  (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
-  _    -> t 
- where
-   mapField (mty,te) = case mty of
-     Just ty -> (mty,mapStr ty f te)
-     _ -> (mty,te)
-}
--- a/src/compiler/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/GF/Compile/Compute/Concrete.hs
@@ -1,3 +1,590 @@
-module GF.Compile.Compute.Concrete{-(module M)-} where
--import GF.Compile.Compute.ConcreteLazy as M -- New
--import GF.Compile.Compute.ConcreteStrict as M -- Old, inefficient
+-- | Functions for computing the values of terms in the concrete syntax, in
+-- | preparation for PMCFG generation.
+module GF.Compile.Compute.Concrete
+           (GlobalEnv, GLocation, resourceValues, geLoc, geGrammar,
+            normalForm,
+            Value(..), Bind(..), Env, value2term, eval, vapply
+           ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import GF.Grammar hiding (Env, VGen, VApp, VRecType)
+import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
+import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
+import GF.Grammar.PatternMatch(matchPattern,measurePatt)
+import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
+import GF.Compile.Compute.Value hiding (Error)
+import GF.Compile.Compute.Predef(predef,predefName,delta)
+import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
+import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM)
+import GF.Data.Utilities(mapFst,mapSnd)
+import GF.Infra.Option
+import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
+import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
+--import Data.Char (isUpper,toUpper,toLower)
+import GF.Text.Pretty
+import qualified Data.Map as Map
+import Debug.Trace(trace)
+
+-- * Main entry points
+
+normalForm :: GlobalEnv -> L Ident -> Term -> Term
+normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
+
+nfx :: GlobalEnv -> Term -> Err Term
+nfx env@(GE _ _ _ loc) t = do
+  v <- eval env [] t
+  return (value2term loc [] v)
+    -- Old value2term error message:
+    -- Left i  -> fail ("variable #"++show i++" is out of scope")
+
+eval :: GlobalEnv -> Env -> Term -> Err Value
+eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
+  where
+    cenv = CE gr rvs opts loc (map fst env)
+
+--apply env = apply' env
+
+--------------------------------------------------------------------------------
+
+-- * Environments
+
+type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
+
+data GlobalEnv = GE Grammar ResourceValues Options GLocation
+data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
+                       opts::Options,
+                       gloc::GLocation,local::LocalScope}
+type GLocation = L Ident
+type LocalScope = [Ident]
+type Stack = [Value]
+type OpenValue = Stack->Value
+
+geLoc     (GE _ _ _ loc) = loc
+geGrammar (GE gr _ _ _)  = gr
+
+ext b env = env{local=b:local env}
+extend bs env = env{local=bs++local env}
+global env = GE (srcgr env) (rvs env) (opts env) (gloc env)
+
+var :: CompleteEnv -> Ident -> Err OpenValue
+var env x = maybe unbound pick' (elemIndex x (local env))
+  where
+    unbound = fail ("Unknown variable: "++showIdent x)
+    pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs)
+    err i vs = bug $ "Stack problem: "++showIdent x++": "
+                    ++unwords (map showIdent (local env))
+                    ++" => "++show (i,length vs)
+    ok v = --trace ("var "++show x++" = "++show v) $
+           v
+
+pick :: Int -> Stack -> Maybe Value
+pick 0 (v:_) = Just v
+pick i (_:vs) = pick (i-1) vs
+pick i vs = Nothing -- bug $ "pick "++show (i,vs)
+
+resource env (m,c) =
+--  err bug id $
+    if isPredefCat c
+    then value0 env =<< lockRecType c defLinType -- hmm
+    else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
+  where e = fail $ "Not found: "++render m++"."++showIdent c
+
+-- | Convert operators once, not every time they are looked up
+resourceValues :: Options -> SourceGrammar -> GlobalEnv
+resourceValues opts gr = env
+  where
+    env = GE gr rvs opts (L NoLoc identW)
+    rvs = Map.mapWithKey moduleResources (moduleMap gr)
+    moduleResources m = Map.mapWithKey (moduleResource m) . jments
+    moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
+                                  let loc = L l c
+                                      qloc = L l (Q (m,c))
+                                  eval (GE gr rvs opts loc) [] (traceRes qloc t)
+
+    traceRes = if flag optTrace opts
+               then traceResource
+               else const id
+
+-- * Tracing
+
+-- | Insert a call to the trace function under the top-level lambdas
+traceResource (L l q) t =
+  case termFormCnc t of
+    (abs,body) -> mkAbs abs (mkApp traceQ [args,body])
+      where
+        args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
+        lstr = render (l<>":"<>ppTerm Qualified 0 q)
+        traceQ = Q (cPredef,cTrace)
+
+-- * Computing values
+
+-- | Computing the value of a top-level term
+value0 :: CompleteEnv -> Term -> Err Value
+value0 env = eval (global env) []
+
+-- | Computing the value of a term
+value :: CompleteEnv -> Term -> Err OpenValue
+value env t0 =
+  -- Each terms is traversed only once by this function, using only statically
+  -- available information. Notably, the values of lambda bound variables
+  -- will be unknown during the term traversal phase.
+  -- The result is an OpenValue, which is a function that may be applied many
+  -- times to different dynamic values, but without the term traversal overhead
+  -- and without recomputing other statically known information.
+  -- For this to work, there should be no recursive calls under lambdas here.
+  -- Whenever we need to construct the OpenValue function with an explicit
+  -- lambda, we have to lift the recursive calls outside the lambda.
+  -- (See e.g. the rules for Let, Prod and Abs)
+{-
+  trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
+                                      brackets (fsep (map ppIdent (local env))),
+                                      ppTerm Unqualified 10 t0]) $
+--}
+  errIn (render t0) $
+  case t0 of
+    Vr x   -> var env x
+    Q x@(m,f)
+      | m == cPredef -> if f==cErrorType                -- to be removed
+                        then let p = identS "P"
+                             in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
+                        else if f==cPBool
+                               then const # resource env x
+                               else const . flip VApp [] # predef f
+      | otherwise    -> const # resource env x --valueResDef (fst env) x
+    QC x   -> return $ const (VCApp x [])
+    App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
+    Let (x,(oty,t)) body -> do vb <- value (ext x env) body
+                               vt <- value env t
+                               return $ \ vs -> vb (vt vs:vs)
+    Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
+    Prod bt x t1 t2 ->
+       do vt1 <- value env t1
+          vt2 <- value (ext x env) t2
+          return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
+    Abs bt x t -> do vt <- value (ext x env) t
+                     return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
+    EInt n -> return $ const (VInt n)
+    EFloat f -> return $ const (VFloat f)
+    K s -> return $ const (VString s)
+    Empty -> return $ const (VString "")
+    Sort s | s == cTok -> return $ const (VSort cStr)        -- to be removed
+           | otherwise -> return $ const (VSort s)
+    ImplArg t -> (VImplArg.) # value env t
+    Table p res -> liftM2 VTblType # value env p <# value env res
+    RecType rs -> do lovs <- mapPairsM (value env) rs
+                     return $ \vs->VRecType $ mapSnd ($vs) lovs
+    t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
+    FV ts   -> ((vfv .) # sequence) # mapM (value env) ts
+    R as    -> do lovs <- mapPairsM (value env.snd) as
+                  return $ \ vs->VRec $ mapSnd ($vs) lovs
+    T i cs  -> valueTable env i cs
+    V ty ts -> do pvs <- paramValues env ty
+                  ((VV ty pvs .) . sequence) # mapM (value env) ts
+    C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2)
+    S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
+    P t l   -> --maybe (bug $ "project "++show l++" from "++show v) id $
+               do ov <- value env t
+                  return $ \ vs -> let v = ov vs
+                                   in maybe (VP v l) id (proj l v)
+    Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
+    Strs ts    -> ((VStrs.) # sequence) # mapM (value env) ts
+    Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
+    ELin c r -> (unlockVRec (gloc env) c.) # value env r
+    EPatt p  -> return $ const (VPatt p) -- hmm
+    EPattType ty -> do vt <- value env ty
+                       return (VPattType . vt)
+    Typed t ty -> value env t
+    t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t
+
+vconcat vv@(v1,v2) =
+    case vv of
+      (VString "",_) -> v2
+      (_,VString "") -> v1
+      (VApp NonExist _,_) -> v1
+      (_,VApp NonExist _) -> v2
+      _ -> VC v1 v2
+
+proj l v | isLockLabel l = return (VRec [])
+                ---- a workaround 18/2/2005: take this away and find the reason
+                ---- why earlier compilation destroys the lock field
+proj l v =
+    case v of
+      VFV vs -> liftM vfv (mapM (proj l) vs)
+      VRec rs -> lookup l rs
+--    VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
+      VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs
+      _ -> return (ok1 VP v l)
+
+ok1 f v1@(VError {}) _ = v1
+ok1 f v1 v2 = f v1 v2
+
+ok2 f v1@(VError {}) _ = v1
+ok2 f _ v2@(VError {}) = v2
+ok2 f v1 v2 = f v1 v2
+
+ok2p f (v1@VError {},_) = v1
+ok2p f (_,v2@VError {}) = v2
+ok2p f vv = f vv
+
+unlockVRec loc c0 v0 = v0
+{-
+unlockVRec loc c0 v0 = unlockVRec' c0 v0
+  where
+    unlockVRec' ::Ident -> Value -> Value
+    unlockVRec' c v =
+        case v of
+    --    VClosure env t -> err bug (VClosure env) (unlockRecord c t)
+          VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v))
+          VRec rs        -> plusVRec rs lock
+    --    _              -> VExtR v (VRec lock) -- hmm
+          _              -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm
+    --    _              -> bugloc loc $ "unlock non-record "++show v0
+      where
+        lock = [(lockLabel c,VRec [])]
+-}
+
+-- suspicious, but backwards compatible
+plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
+  where ls2 = map fst rs2
+
+extR t vv =
+    case vv of
+      (VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
+      (v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
+      (VRecType rs1, VRecType rs2) ->
+          case intersect (map fst rs1) (map fst rs2) of
+            [] -> VRecType (rs1 ++ rs2)
+            ls -> error $ "clash"<+>show ls
+      (VRec     rs1, VRec     rs2) -> plusVRec rs1 rs2
+      (v1          , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
+      (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
+--    (v1,v2) -> ok2 VExtR v1 v2 -- hmm
+      (v1,v2) -> error $ "not records" $$ show v1 $$ show v2
+  where
+    error explain = ppbug $ "The term" <+> t
+                            <+> "is not reducible" $$ explain
+
+glue env (v1,v2) = glu v1 v2
+  where
+    glu v1 v2 =
+        case (v1,v2) of
+          (VFV vs,v2) -> vfv [glu v1 v2|v1<-vs]
+          (v1,VFV vs) -> vfv [glu v1 v2|v2<-vs]
+          (VString s1,VString s2) -> VString (s1++s2)
+          (v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
+             where glx v2 = glu v1 v2
+          (v1@(VAlts {}),v2) ->
+           --err (const (ok2 VGlue v1 v2)) id $
+             err bug id $
+             do y' <- strsFromValue v2
+                x' <- strsFromValue v1
+                return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
+          (VC va vb,v2) -> VC va (glu vb v2)
+          (v1,VC va vb) -> VC (glu v1 va) vb
+          (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb
+          (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb
+          (v1@(VApp NonExist _),_) -> v1
+          (_,v2@(VApp NonExist _)) -> v2
+--        (v1,v2) -> ok2 VGlue v1 v2
+          (v1,v2) -> if flag optPlusAsBind (opts env)
+                       then VC v1 (VC (VApp BIND []) v2)
+                       else let loc  = gloc env
+                                vt v = value2term loc (local env) v
+                                        -- Old value2term error message:
+                                        --  Left i  -> Error ('#':show i)
+                                originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
+                                                               (Glue (vt v1) (vt v2)))
+                                term = render $ pp  $ Glue (vt v1) (vt v2)
+                            in error $ unlines
+                                [originalMsg
+                                ,""
+                                ,"There was a problem in the expression `"++term++"`, either:"
+                                ,"1) You are trying to use + on runtime arguments, possibly via an oper."
+                                ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive."
+                                ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md"
+                                ]
+
+
+-- | to get a string from a value that represents a sequence of terminals
+strsFromValue :: Value -> Err [Str]
+strsFromValue t = case t of
+  VString s   -> return [str s]
+  VC s t -> do
+    s' <- strsFromValue s
+    t' <- strsFromValue t
+    return [plusStr x y | x <- s', y <- t']
+{-
+  VGlue s t -> do
+    s' <- strsFromValue s
+    t' <- strsFromValue t
+    return [glueStr x y | x <- s', y <- t']
+-}
+  VAlts d vs -> do
+    d0 <- strsFromValue d
+    v0 <- mapM (strsFromValue . fst) vs
+    c0 <- mapM (strsFromValue . snd) vs
+  --let vs' = zip v0 c0
+    return [strTok (str2strings def) vars |
+              def  <- d0,
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
+                                                          vv <- sequence v0]
+           ]
+  VFV ts -> concat # mapM strsFromValue ts
+  VStrs ts -> concat # mapM strsFromValue ts
+
+  _ -> fail ("cannot get Str from value " ++ show t)
+
+vfv vs = case nub vs of
+           [v] -> v
+           vs -> VFV vs
+
+select env vv =
+    case vv of
+      (v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs]
+      (VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs]
+      (v1@(VV pty vs rs),v2) ->
+         err (const (VS v1 v2)) id $
+         do --ats <- allParamValues (srcgr env) pty
+            --let vs = map (value0 env) ats
+            i <- maybeErr "no match" $ findIndex (==v2) vs
+            return (ix (gloc env) "select" rs i)
+      (VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
+      (v1@(VT _ _ cs),v2) ->
+                 err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
+                 match (gloc env) cs v2
+      (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
+      (v1,v2) -> ok2 VS v1 v2
+
+match loc cs v =
+  err bad return (matchPattern cs (value2term loc [] v))
+    -- Old value2term error message:
+    -- Left i  -> bad ("variable #"++show i++" is out of scope")
+  where
+    bad = fail . ("In pattern matching: "++)
+
+valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
+valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
+
+valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
+valueTable env i cs =
+    case i of
+      TComp ty -> do pvs <- paramValues env ty
+                     ((VV ty pvs .) # sequence) # mapM (value env.snd) cs
+      _ -> do ty <- getTableType i
+              cs' <- mapM valueCase cs
+              err (dynamic cs' ty) return (convert cs' ty)
+  where
+    dynamic cs' ty _ = cases cs' # value env ty
+
+    cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs))
+      where
+        keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $
+                   VT wild (vty vs) (mapSnd ($vs) cs')
+
+    wild = case i of TWild _ -> True; _ -> False
+
+    convertv cs' vty =
+      convert' cs' =<< paramValues'' env (value2term (gloc env) [] vty)
+        -- Old value2term error message: Left i    -> fail ("variable #"++show i++" is out of scope")
+
+    convert cs' ty = convert' cs' =<< paramValues' env ty
+
+    convert' cs' ((pty,vs),pvs) =
+      do sts  <- mapM (matchPattern cs') vs
+         return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
+                                           (mapFst ($vs) sts)
+
+    valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
+                         pvs <- linPattVars p'
+                         vt <- value (extend pvs env) t
+                         return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs))
+
+    inlinePattMacro p =
+        case p of
+          PM qc -> do r <- resource env qc
+                      case r of
+                        VPatt p' -> inlinePattMacro p'
+                        _ -> ppbug $ hang "Expected pattern macro:" 4
+                                          (show r)
+          _ -> composPattOp inlinePattMacro p
+
+
+paramValues env ty = snd # paramValues' env ty
+
+paramValues' env ty = paramValues'' env =<< nfx (global env) ty
+
+paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
+                           pvs <- mapM (eval (global env) []) ats
+                           return ((pty,ats),pvs)
+
+push' p bs xs = if length bs/=length xs
+                then bug $ "push "++show (p,bs,xs)
+                else push bs xs
+
+push :: Env -> LocalScope -> Stack -> Stack
+push bs [] vs = vs
+push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
+  where  err = bug $ "Unbound pattern variable "++showIdent x
+
+apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
+apply' env t [] = value env t
+apply' env t vs =
+  case t of
+    QC x                   -> return $ \ svs -> VCApp x (map ($svs) vs)
+{-
+    Q x@(m,f) | m==cPredef -> return $
+                              let constr = --trace ("predef "++show x) .
+                                           VApp x
+                              in \ svs -> maybe constr id (Map.lookup f predefs)
+                                          $ map ($svs) vs
+              | otherwise  -> do r <- resource env x
+                                 return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
+-}
+    App t1 t2              -> apply' env t1 . (:vs) =<< value env t2
+    _                      -> do fv <- value env t
+                                 return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
+
+vapply :: GLocation -> Value -> [Value] -> Value
+vapply loc v [] = v
+vapply loc v vs =
+  case v of
+    VError {} -> v
+--  VClosure env (Abs b x t) -> beta gr env b x t vs
+    VAbs bt _ (Bind f) -> vbeta loc bt f vs
+    VApp pre vs1 -> delta' pre (vs1++vs)
+      where
+        delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
+                                  in vtrace loc v1 vr
+        delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
+        --msg = const (VApp pre (vs1++vs))
+        msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
+    VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
+    VFV fs -> vfv [vapply loc f vs|f<-fs]
+    VCApp f vs0 -> VCApp f (vs0++vs)
+    VMeta i env vs0 -> VMeta i env (vs0++vs)
+    VGen i vs0 -> VGen i (vs0++vs)
+    v -> bug $ "vapply "++show v++" "++show vs
+
+vbeta loc bt f (v:vs) =
+  case (bt,v) of
+    (Implicit,VImplArg v) -> ap v
+    (Explicit,         v) -> ap v
+  where
+    ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
+    ap v         = vapply loc (f v) vs
+
+vary (VFV vs) = vs
+vary v = [v]
+varyList = mapM vary
+
+{-
+beta env b x t (v:vs) =
+  case (b,v) of
+    (Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
+    (Explicit,         v) -> apply' (ext (x,v) env) t vs
+-}
+
+vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
+  where
+    pv v = case v of
+             VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
+             _ -> ppV v
+    pf (_,VString n) = pp n
+    pf (_,v) = ppV v
+    pa (_,v) = ppV v
+    ppV v = ppTerm Unqualified 10 (value2term' True loc [] v)
+              -- Old value2term error message:
+              -- Left i  -> "variable #" <> pp i <+> "is out of scope"
+
+-- | Convert a value back to a term
+value2term :: GLocation -> [Ident] -> Value -> Term
+value2term = value2term' False
+
+value2term' :: Bool -> p -> [Ident] -> Value -> Term
+value2term' stop loc xs v0 =
+  case v0 of
+    VApp pre vs    -> applyMany (Q (cPredef,predefName pre)) vs
+    VCApp f vs     -> applyMany (QC f)                       vs
+    VGen j vs      -> applyMany (var j)                      vs
+    VMeta j env vs -> applyMany (Meta j)                     vs
+    VProd bt v x f -> Prod bt x (v2t v)  (v2t' x f)
+    VAbs  bt   x f -> Abs  bt x          (v2t' x f)
+    VInt n         -> EInt n
+    VFloat f       -> EFloat f
+    VString s      -> if null s then Empty else K s
+    VSort s        -> Sort s
+    VImplArg v     -> ImplArg (v2t v)
+    VTblType p res -> Table (v2t p) (v2t res)
+    VRecType rs    -> RecType [(l, v2t v) | (l,v) <- rs]
+    VRec as        -> R       [(l, (Nothing, v2t v)) | (l,v) <- as]
+    VV t _ vs      -> V t     (map v2t vs)
+    VT wild v cs   -> T ((if wild then TWild else TTyped) (v2t v)) (map nfcase cs)
+    VFV vs         -> FV (map v2t vs)
+    VC v1 v2       -> C (v2t v1) (v2t v2)
+    VS v1 v2       -> S (v2t v1) (v2t v2)
+    VP v l         -> P (v2t v) l
+    VPatt p        -> EPatt p
+    VPattType v    -> EPattType $ v2t v
+    VAlts v vvs    -> Alts (v2t v) [(v2t x, v2t y) | (x,y) <- vvs]
+    VStrs vs       -> Strs (map v2t vs)
+--  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
+--  VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
+    VError err     -> Error err
+  where
+    applyMany f vs = foldl App f (map v2t vs)
+    v2t = v2txs xs
+    v2txs = value2term' stop loc
+    v2t' x f = v2txs (x:xs) (bind f (gen xs))
+
+    var j
+      | j<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
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
@@ -1,580 +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,combinations,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
-                            in error . render $
-                                         ppL loc (hang "unsupported token gluing:" 4
-                                                        (Glue (vt v1) (vt v2)))
-
-
-- | 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 <- combinations 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:" 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
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/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
--- a/src/compiler/GF/Compile/Compute/Value.hs
+++ b/src/compiler/GF/Compile/Compute/Value.hs
@@ -12,8 +12,8 @@ data Value
  | VGen Int [Value] -- for lambda bound variables, possibly applied
  | VMeta MetaId Env [Value]
 -- -- | VClosure Env Term -- used in Typecheck.ConcreteNew
-  | VAbs BindType Ident Binding -- used in Compute.ConcreteNew
-  | VProd BindType Value Ident Binding -- used in Compute.ConcreteNew
+  | VAbs BindType Ident Binding -- used in Compute.Concrete
+  | VProd BindType Value Ident Binding -- used in Compute.Concrete
  | VInt Int
  | VFloat Double
  | VString String
@@ -47,10 +47,10 @@ type Env = [(Ident,Value)]

 -- | Predefined functions
 data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
-                | ToLower | IsUpper | Length | Plus | EqInt | LessInt 
+                | ToLower | IsUpper | Length | Plus | EqInt | LessInt
             {- | Show | Read | ToStr | MapStr | EqVal -}
                | Error | Trace
                -- Canonical values below:
-                | PBool | PFalse | PTrue | Int | Float | Ints | NonExist 
+                | PBool | PFalse | PTrue | Int | Float | Ints | NonExist
                | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
                deriving (Show,Eq,Ord,Ix,Bounded,Enum)
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -1,365 +1,350 @@
 -- | Translate concrete syntax to Haskell
 module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
-import Data.List(sort,sortBy)
-import Data.Function(on)
+import Data.List(isPrefixOf,sort,sortOn)
 import qualified Data.Map as M
 import qualified Data.Set as S
-import GF.Data.ErrM
-import GF.Data.Utilities(mapSnd)
 import GF.Text.Pretty
-import GF.Grammar.Grammar
-import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos)--,allParamValues
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp)
-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(Ident,identS,prefixIdent) --,moduleNameS
+--import GF.Grammar.Predef(cPredef,cInts)
+--import GF.Compile.Compute.Predef(predef)
+--import GF.Compile.Compute.Value(Predefined(..))
+import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
 import GF.Infra.Option
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
-import GF.Haskell
-import Debug.Trace
+import GF.Haskell as H
+import GF.Grammar.Canonical as C
+import GF.Compile.GrammarToCanonical
+import Debug.Trace(trace)

 -- | Generate Haskell code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
 concretes2haskell opts absname gr =
-  [(cncname,concrete2haskell opts gr cenv absname cnc cncmod)
-     | let cenv = resourceValues opts gr,
-       cnc<-allConcretes gr absname,
-       let cncname = render cnc ++ ".hs" :: FilePath
-           Ok cncmod = lookupModule gr cnc
+  [(filename,render80 $ concrete2haskell opts abstr cncmod)
+     | let Grammar abstr cncs = grammar2canonical opts absname gr,
+       cncmod<-cncs,
+       let ModId name = concName cncmod
+           filename = showRawIdent name ++ ".hs" :: FilePath
  ]

 -- | Generate Haskell code for the given concrete module.
 -- The only options that make a difference are
 -- @-haskell=noprefix@ and @-haskell=variants@.
-concrete2haskell opts gr cenv absname cnc modinfo =
-    renderStyle style{lineLength=80,ribbonsPerLine=1} $
-      haskPreamble va absname cnc $$ vcat (
-      nl:Comment "--- Parameter types ---":
-      neededParamTypes S.empty (params defs) ++
-      nl:Comment "--- Type signatures for linearization functions ---":
-      map signature (S.toList allcats)++
-      nl:Comment "--- Linearization functions for empty categories ---":
-      emptydefs ++
-      nl:Comment "--- Linearization types and linearization functions ---":
-      map ppDef defs ++
-      nl:Comment "--- Type classes for projection functions ---":
-      map labelClass (S.toList labels) ++
-      nl:Comment "--- Record types ---":
-      concatMap recordType recs)
+concrete2haskell opts
+                 abstr@(Abstract _ _ cats funs)
+                 modinfo@(Concrete cnc absname _ ps lcs lns) =
+  haskPreamble absname cnc $$
+  vcat (
+    nl:Comment "--- Parameter types ---":
+    map paramDef ps ++
+    nl:Comment "--- Type signatures for linearization functions ---":
+    map signature cats ++
+    nl:Comment "--- Linearization functions for empty categories ---":
+    emptydefs ++
+    nl:Comment "--- Linearization types ---":
+    map lincatDef lcs ++
+    nl:Comment "--- Linearization functions ---":
+    lindefs ++
+    nl:Comment "--- Type classes for projection functions ---":
+    map labelClass (S.toList labels) ++
+    nl:Comment "--- Record types ---":
+    concatMap recordType recs)
  where
    nl = Comment ""
+    recs = S.toList (S.difference (records (lcs,lns)) common_records)
+
    labels = S.difference (S.unions (map S.fromList recs)) common_labels
-    recs = S.toList (S.difference (records rhss) common_records)
    common_records = S.fromList [[label_s]]
    common_labels = S.fromList [label_s]
-    label_s = ident2label (identS "s")
+    label_s = LabelId (rawIdentS "s")

-    rhss = map (either snd (snd.snd)) defs
-    defs = sortBy (compare `on` either (const Nothing) (Just . fst)) .
-           concatMap (toHaskell gId gr absname cenv) . 
-           M.toList $
-           jments modinfo
-
--  signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c
--  signature c = "--lin"<>c<+>":: (Applicative f,Monad f) =>"<+>"A."<>gId c<+>"->"<+>"f Lin"<>c
-    signature c = TypeSig lf (Fun abs (pure lin))
+    signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
      where
        abs = tcon0 (prefixIdent "A." (gId c))
        lin = tcon0 lc
-        lf = prefixIdent "lin" c
-        lc = prefixIdent "Lin" c
+        lf = linfunName c
+        lc = lincatName c

    emptydefs = map emptydef (S.toList emptyCats)
-    emptydef c = Eqn (prefixIdent "lin" c,[WildP]) (Const "undefined")
+    emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")

-    emptyCats = allcats `S.difference` cats
-    cats = S.fromList [c|Right (c,_)<-defs]
-    allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname]
+    emptyCats = allcats `S.difference` linfuncats
+      where
+     --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
+       allcats = S.fromList [c | CatDef c _<-cats]

-    params = S.toList . S.unions . map params1
-    params1 (Left (_,rhs)) = paramTypes gr rhs
-    params1 (Right (_,(_,rhs))) = tableTypes gr [rhs]
+    gId :: ToIdent i => i -> Ident
+    gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
+          . toIdent

-    ppDef (Left (lhs,rhs)) = lhs (convType va gId rhs)
-    ppDef (Right (_,(lhs,rhs))) = lhs (convert va gId gr rhs)
-
-    gId :: Ident -> Ident
-    gId = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G"
    va = haskellOption opts HaskellVariants
    pure = if va then ListT else id

-    neededParamTypes have [] = []
-    neededParamTypes have (q:qs) =
-        if q `S.member` have
-        then neededParamTypes have qs
-        else let ((got,need),def) = paramType va gId gr q
-             in def++neededParamTypes (S.union got have) (S.toList need++qs)
-
-haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc
-haskPreamble va absname cncname =
-  "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
-  "module" <+> cncname <+> "where" $$
-  "import Prelude hiding (Ordering(..))" $$
-  "import Control.Applicative((<$>),(<*>))" $$
-  "import PGF.Haskell" $$
-  "import qualified" <+> absname <+> "as A" $$
-  "" $$
-  "--- Standard definitions ---" $$
-  "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
-  "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
-  "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
-  "" $$
-  "----------------------------------------------------" $$
-  "-- Automatic translation from GF to Haskell follows" $$
-  "----------------------------------------------------"
-  where
-    pure = if va then brackets else pp
-
-toHaskell gId gr absname cenv (name,jment) =
-  case jment of
-    CncCat (Just (L loc typ)) _ _ pprn _ ->
-        [Left (tsyn0 (prefixIdent "Lin" name),nf loc typ)]
-    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
--      trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $
-        [Right (cat,(Eqn (prefixIdent "lin" cat,lhs),coerce [] lincat rhs))]
+    haskPreamble :: ModId -> ModId -> Doc
+    haskPreamble absname cncname =
+      "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
+      "module" <+> cncname <+> "where" $$
+      "import Prelude hiding (Ordering(..))" $$
+      "import Control.Applicative((<$>),(<*>))" $$
+      "import PGF.Haskell" $$
+      "import qualified" <+> absname <+> "as A" $$
+      "" $$
+      "--- Standard definitions ---" $$
+      "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
+      "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
+      "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
+      "" $$
+      "----------------------------------------------------" $$
+      "-- Automatic translation from GF to Haskell follows" $$
+      "----------------------------------------------------"
      where
-        Ok abstype = lookupFunType gr absname name
-        (absctx,_abscat,_absargs) = typeForm abstype
+        pure = if va then brackets else pp

-        e' = unAbs (length params) $
-             nf loc (mkAbs params (mkApp def (map Vr args)))
-        params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx]
-        args = map snd params
-        abs_args = map (prefixIdent "abs_") args
-        lhs = [ConP (aId name) (map VarP abs_args)]
-        rhs = foldr letlin e' (zip args absctx)
-        letlin (a,(_,_,at)) =
-           Let (a,(Just (con ("Lin"++render at)),(App (con ("lin"++render at)) (con ("abs_"++render a)))))
-    AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
-                     Ok (m,jment) -> toHaskell gId gr absname cenv (name,jment)
-                     _ -> []
-    _ -> []
-  where
-    nf loc = normalForm cenv (L loc name)
-    aId n = prefixIdent "A." (gId n)
+    paramDef pd =
+      case pd of
+        ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
+        ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
+          where
+            paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
+            derive = ["Eq","Ord","Show"]

-    unAbs 0 t = t
-    unAbs n (Abs _ _ t) = unAbs (n-1) t
-    unAbs _ t = t
+    convLinType = ppT
+      where
+        ppT t =
+          case t of
+            FloatType -> tcon0 (identS "Float")
+            IntType -> tcon0 (identS "Int")
+            ParamType (ParamTypeId p) -> tcon0 (gId p)
+            RecordType rs -> tcon (rcon' ls) (map ppT ts)
+              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
+            StrType -> tcon0 (identS "Str")
+            TableType pt lt -> Fun (ppT pt) (ppT lt)
+--          TupleType lts ->
+
+    lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
+
+    linfuncats = S.fromList linfuncatl
+    (linfuncatl,lindefs) = unzip (linDefs lns)
+
+    linDefs = map eqn . sortOn fst . map linDef
+      where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
+
+    linDef (LinDef f xs rhs0) =
+        (cat,(linfunName cat,(lhs,rhs)))
+      where
+        lhs = [ConP (aId f) (map VarP abs_args)]
+        aId f = prefixIdent "A." (gId f)
+
+        [lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
+        [C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
+
+        abs_args = map abs_arg args
+        abs_arg = prefixIdent "abs_"
+        args = map (prefixIdent "g" . toIdent) xs
+
+        rhs = lets (zipWith letlin args absctx)
+                   (convert vs (coerce env lincat rhs0))
+          where
+            vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
+            env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
+
+        letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
+          (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
+
+        arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
+          where
+            [lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
+
+    convert = convert' va
+
+    convert' va vs = ppT
+      where
+        ppT0 = convert' False vs
+        ppTv vs' = convert' va vs'
+
+        pure = if va then single else id
+
+        ppT t =
+          case t of
+            TableValue ty cs -> pure (table cs)
+            Selection t p -> select (ppT t) (ppT p)
+            ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
+            RecordValue r -> aps (rcon ls) (map ppT ts)
+              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
+            PredefValue p -> single (Var (toIdent p)) -- hmm
+            Projection t l -> ap (proj l) (ppT t)
+            VariantValue [] -> empty
+            VariantValue ts@(_:_) -> variants ts
+            VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
+            PreValue vs t' -> pure (alts t' vs)
+            ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
+            ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
+            LiteralValue l -> ppL l
+            _ -> error ("convert "++show t)
+
+        ppL l =
+          case l of
+            FloatConstant x -> pure (lit x)
+            IntConstant n -> pure (lit n)
+            StrConstant s -> pure (token s)
+
+        pId p@(ParamId s) =
+          if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
+
+        table cs =
+            if all (null.patVars) ps
+            then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
+            else LambdaCase (map ppCase cs)
+          where
+            (ds,ts') = dedup ts
+            (ps,ts) = unzip [(p,t)|TableRow p t<-cs]
+        ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
+{-
+        ppPredef n =
+          case predef n of
+            Ok BIND       -> single (c "BIND")
+            Ok SOFT_BIND  -> single (c "SOFT_BIND")
+            Ok SOFT_SPACE -> single (c "SOFT_SPACE")
+            Ok CAPIT      -> single (c "CAPIT")
+            Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
+            _ -> Var n
+-}
+        ppP p =
+          case p of
+            ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
+            RecordPattern r -> ConP (rcon' ls) (map ppP ps)
+              where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
+            WildPattern -> WildP
+
+        token s = single (c "TK" `Ap` lit s)
+
+        alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
+          where
+            alt (s,t) = Pair (List (pre s)) (ppT0 t)
+            pre s = map lit s
+
+        c = Const
+        lit s = c (show s) -- hmm
+        concat = if va then concat' else plusplus
+          where
+            concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
+            concat' t1 t2 = Op t1 "+++" t2
+
+        pure' = single -- forcing the list monad
+
+        select = if va then select' else Ap
+        select' (List [t]) (List [p]) = Op t "!" p
+        select' (List [t]) p = Op t "!$" p
+        select' t p = Op t "!*" p
+
+        ap = if va then ap' else Ap
+          where
+            ap' (List [f]) x = fmap f x
+            ap' f x = Op f "<*>" x
+            fmap f (List [x]) = pure' (Ap f x)
+            fmap f x = Op f "<$>" x
+
+    --  join = if va then join' else id
+        join' (List [x]) = x
+        join' x = c "concat" `Ap` x
+
+        empty = if va then List [] else c "error" `Ap` c (show "empty variant")
+        variants = if va then \ ts -> join' (List (map ppT ts))
+                         else \ (t:_) -> ppT t
+
+        aps f [] = f
+        aps f (a:as) = aps (ap f a) as
+
+        dedup ts =
+            if M.null dups
+            then ([],map ppT ts)
+            else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
+          where
+            entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
+            ev i = identS ("e'"++show i)
+
+            defs = [(i1,t)|(t,i1:_:_)<-ms]
+            dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
+            ms = M.toList m
+            m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
+            is = [0..]::[Int]


-con = Cn . identS
+--con = Cn . identS

-tableTypes gr ts = S.unions (map tabtys ts)
-  where
-    tabtys t =
-      case t of
-        V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
-        T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
-        _ -> collectOp tabtys t
+class Records t where
+  records :: t -> S.Set [LabelId]

-paramTypes gr t =
-  case t of
-    RecType fs -> S.unions (map (paramTypes gr.snd) fs)
-    Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
-    App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
-    Sort _ -> S.empty
-    EInt _ -> S.empty
-    Q q -> lookup q
-    QC q -> lookup q
-    FV ts -> S.unions (map (paramTypes gr) ts)
-    _ -> ignore
-  where
-    lookup q = case lookupOrigInfo gr q of
-                 Ok (_,ResOper  _ (Just (L _ t))) ->
-                                       S.insert q (paramTypes gr t)
-                 Ok (_,ResParam {}) -> S.singleton q
-                 _ -> ignore
+instance Records t => Records [t] where
+  records = S.unions . map records

-    ignore = trace ("Ignore: "++show t) S.empty
-
-
-
-records ts = S.unions (map recs ts)
-  where
-    recs t =
-      case t of
-        R r -> S.insert (labels r) (records (map (snd.snd) r))
-        RecType r -> S.insert (labels r) (records (map snd r))
-        _ -> collectOp recs t
-
-    labels = sort . filter (not . isLockLabel) . map fst
+instance (Records t1,Records t2) => Records (t1,t2) where
+  records (t1,t2) = S.union (records t1) (records t2)
+
+instance Records LincatDef where
+  records (LincatDef _ lt) = records lt
+
+instance Records LinDef where
+  records (LinDef _ _ lv) = records lv
+
+instance Records LinType where
+  records t =
+    case t of
+      RecordType r -> rowRecords r
+      TableType pt lt -> records (pt,lt)
+      TupleType ts -> records ts
+      _ -> S.empty
+
+rowRecords r = S.insert (sort ls) (records ts)
+  where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
+
+instance Records LinValue where
+  records v =
+    case v of
+      ConcatValue v1 v2 -> records (v1,v2)
+      ParamConstant (Param c vs) -> records vs
+      RecordValue r -> rowRecords r
+      TableValue t r -> records (t,r)
+      TupleValue vs -> records vs
+      VariantValue vs -> records vs
+      PreValue alts d -> records (map snd alts,d)
+      Projection v l -> records v
+      Selection v1 v2 -> records (v1,v2)
+      _ -> S.empty
+
+instance Records rhs => Records (TableRow rhs) where
+  records (TableRow _ v) = records v


+-- | Record subtyping is converted into explicit coercions in Haskell
 coerce env ty t =
-  case (ty,t) of 
-    (_,Let d t) -> Let d (coerce (extend env d) ty t)
-    (_,FV ts) -> FV (map (coerce env ty) ts)
-    (Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts)
-    (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs)
-    (RecType rt,R r) ->
-      R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
-    (RecType rt,Vr x)->
+  case (ty,t) of
+    (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
+    (TableType ti tv,TableValue _ cs) ->
+      TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
+    (RecordType rt,RecordValue r) ->
+      RecordValue [RecordRow l (coerce env ft f) |
+                     RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
+    (RecordType rt,VarValue x)->
      case lookup x env of
        Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
-          --trace ("coerce "++render ty'++" to "++render ty) $
-          App (to_rcon (map fst rt)) t
-        _ -> trace ("no coerce to "++render ty) t
+                            --trace ("coerce "++render ty'++" to "++render ty) $
+                            app (to_rcon rt) [t]
+                 | otherwise -> t -- types match, no coercion needed
+        _ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
+                            $$ "in" <+> map fst env))
+                   t
    _ -> t
  where
-    extend env (x,(Just ty,rhs)) = (x,ty):env
-    extend env _ = env
+    app f ts = ParamConstant (Param f ts) -- !! a hack
+    to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels

-convert va gId gr = convert' va gId [] gr
+patVars p = []

-convert' va gId vs gr = ppT
-  where
-    ppT0 = convert' False gId vs gr
-    ppTv vs' = convert' va gId vs' gr
+labels r = [l | RecordRow l _ <- r]

-    ppT t =
-      case t of
-         -- Only for 'let' inserted on the top-level by this converter:
-        Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t)
--      Abs b x t -> ...
-        V ty ts -> pure (c "table" `Ap` dedup ts)
-        T (TTyped ty) cs -> pure (LambdaCase (map ppCase cs))
-        S t p -> select (ppT t) (ppT p)
-        C t1 t2 -> concat (ppT t1) (ppT t2)
-        App f a -> ap (ppT f) (ppT a)
-        R r -> aps (ppT (rcon (map fst r))) (fields r)
-        P t l -> ap (ppT (proj l)) (ppT t)
-        FV [] -> empty
-        Vr x -> if x `elem` vs then pure (Var x) else Var x
-        Cn x -> pure (Var x)
-        Con c -> pure (Var (gId c))
-        Sort k -> pure (Var k)
-        EInt n -> pure (lit n)
-        Q (m,n) -> if m==cPredef then pure (ppPredef n) else Var (qual m n)
-        QC (m,n) -> pure (Var (gId (qual m n)))
-        K s -> pure (token s)
-        Empty -> pure (List [])
-        FV ts@(_:_) -> variants ts
-        Alts t' vs -> pure (alts t' vs)
-
-    ppCase (p,t) = (ppP p,ppTv (patVars p++vs) t)
-
-    ppPredef n =
-      case predef n of
-        Ok BIND       -> single (c "BIND")
-        Ok SOFT_BIND  -> single (c "SOFT_BIND")
-        Ok SOFT_SPACE -> single (c "SOFT_SPACE")
-        Ok CAPIT      -> single (c "CAPIT")
-        Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
-        _ -> Var n
-
-    ppP p =
-      case p of
-        PC c ps -> ConP (gId c) (map ppP ps)
-        PP (_,c) ps -> ConP (gId c) (map ppP ps)
-        PR r -> ConP (rcon' (map fst r)) (map (ppP.snd) (filter (not.isLockLabel.fst) r))
-        PW -> WildP
-        PV x -> VarP x
-        PString s -> Lit (show s) -- !!
-        PInt i -> Lit (show i)
-        PFloat x -> Lit (show x)
-        PT _ p -> ppP p
-        PAs x p -> AsP x (ppP p)
-        
-    token s = single (c "TK" `Ap` lit s)
-
-    alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
-      where
-        alt (t,p) = Pair (List (pre p)) (ppT0 t)
-
-        pre (K s) = [lit s]
-        pre (Strs ts) = concatMap pre ts
-        pre (EPatt p) = pat p
-        pre t = error $ "pre "++show t
-
-        pat (PString s) = [lit s]
-        pat (PAlt p1 p2) = pat p1++pat p2
-        pat p = error $ "pat "++show p
-
-    fields = map (ppT.snd.snd) . sort . filter (not.isLockLabel.fst)
-
-    c = Const
-    lit s = c (show s) -- hmm
-    concat = if va then concat' else plusplus
-      where
-        concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
-        concat' t1 t2 = Op t1 "+++" t2
-    pure = if va then single else id
-    pure' = single -- forcing the list monad
-
-    select = if va then select' else Ap
-    select' (List [t]) (List [p]) = Op t "!" p
-    select' (List [t]) p = Op t "!$" p
-    select' t p = Op t "!*" p
-
-    ap = if va then ap' else Ap
-      where
-        ap' (List [f]) x = fmap f x
-        ap' f x = Op f "<*>" x
-        fmap f (List [x]) = pure' (Ap f x)
-        fmap f x = Op f "<$>" x
-
--  join = if va then join' else id
-    join' (List [x]) = x
-    join' x = c "concat" `Ap` x
-
-    empty = if va then List [] else c "error" `Ap` c (show "empty variant")
-    variants = if va then \ ts -> join' (List (map ppT ts))
-                     else \ (t:_) -> ppT t
-
-    aps f [] = f
-    aps f (a:as) = aps (ap f a) as
-
-    dedup ts =
-        if M.null dups
-        then List (map ppT ts)
-        else Lets [(ev i,ppT t)|(i,t)<-defs] (List (zipWith entry ts is))
-      where
-        entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
-        ev i = identS ("e'"++show i)
-
-        defs = [(i1,t)|(t,i1:_:_)<-ms]
-        dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
-        ms = M.toList m
-        m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
-        is = [0..]::[Int]
-
-patVars p =
-  case p of
-    PV x -> [x]
-    PAs x p -> x:patVars p
-    _ -> collectPattOp patVars p
-
-convType va gId = ppT
-  where
-    ppT t =
-      case t of
-        Table ti tv -> Fun (ppT ti) (if va then ListT (ppT tv) else ppT tv)
-        RecType rt -> tcon (rcon' (map fst rt)) (fields rt)
-        App tf ta -> TAp (ppT tf) (ppT ta)
-        FV [] -> tcon0 (identS "({-empty variant-})")
-        Sort k -> tcon0 k
-        EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
-        FV (t:ts) -> ppT t -- !!
-        QC (m,n) -> tcon0 (gId (qual m n))
-        Q (m,n) -> tcon0 (gId (qual m n))
-        _ -> error $ "Missing case in convType for: "++show t
-
-    fields = map (ppT.snd) . sort . filter (not.isLockLabel.fst)
-
-proj = con . proj'
-proj' l = "proj_"++render l
-rcon = con . rcon_name
+proj = Var . identS . proj'
+proj' (LabelId l) = "proj_" ++ showRawIdent l
+rcon = Var . rcon'
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
-to_rcon = con . to_rcon'
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
 to_rcon' = ("to_"++) . rcon_name

 recordType ls =
@@ -400,31 +385,6 @@ labelClass l =
    r = identS "r"
    a = identS "a"

-paramType va gId gr q@(_,n) =
-    case lookupOrigInfo gr q of
-      Ok (m,ResParam (Just (L _ ps)) _)
-       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
-         ((S.singleton (m,n),argTypes ps),
-          [Data (conap0 name) (map (param m) ps)["Eq","Ord","Show"],
-           Instance [] (TId (identS "EnumAll") `TAp` TId name)
-              [(lhs0 "enumAll",foldr1 plusplus (map (enumParam m) ps))]]
-         )
-       where name = gId (qual m n)
-      Ok (m,ResOper  _ (Just (L _ t)))
-        | m==cPredef && n==cInts ->
-           ((S.singleton (m,n),S.empty),
-            [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])
-        | otherwise ->
-           ((S.singleton (m,n),paramTypes gr t),
-            [Type (conap0 (gId (qual m n))) (convType va gId t)])
-      _ -> ((S.empty,S.empty),[])
-  where
-    param m (n,ctx) = ConAp (gId (qual m n)) [convType va gId t|(_,_,t)<-ctx]
-    argTypes = S.unions . map argTypes1
-    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
-
-    enumParam m (n,ctx) = enumCon (gId (qual m n)) (length ctx)
-
 enumCon name arity =
    if arity==0
    then single (Var name)
@@ -433,5 +393,23 @@ enumCon name arity =
    ap (List [f]) a = Op f "<$>" a
    ap f a = Op f "<*>" a

-qual :: ModuleName -> Ident -> Ident
-qual m = prefixIdent (render m++"_")
+lincatName,linfunName :: CatId -> Ident
+lincatName c = prefixIdent "Lin" (toIdent c)
+linfunName c = prefixIdent "lin" (toIdent c)
+
+class ToIdent i where toIdent :: i -> Ident
+
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
+instance ToIdent CatId   where toIdent (CatId s) = identC s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
+
+qIdentC = identS . unqual
+
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
+unqual (Unqual n) = showRawIdent n
+
+instance ToIdent VarId where
+  toIdent Anonymous = identW
+  toIdent (VarId s) = identC s
--- a/src/compiler/GF/Compile/Export.hs
+++ b/src/compiler/GF/Compile/Export.hs
@@ -3,9 +3,11 @@ module GF.Compile.Export where
 import PGF
 import PGF.Internal(ppPGF)
 import GF.Compile.PGFtoHaskell
+--import GF.Compile.PGFtoAbstract
 import GF.Compile.PGFtoJava
 import GF.Compile.PGFtoProlog
 import GF.Compile.PGFtoJS
+import GF.Compile.PGFtoJSON
 import GF.Compile.PGFtoPython
 import GF.Infra.Option
 --import GF.Speech.CFG
@@ -34,7 +36,10 @@ exportPGF :: Options
 exportPGF opts fmt pgf = 
    case fmt of
      FmtPGFPretty    -> multi "txt" (render . ppPGF)
+      FmtCanonicalGF  -> [] -- canon "gf" (render80 . abstract2canonical)
+      FmtCanonicalJson-> []
      FmtJavaScript   -> multi "js"  pgf2js
+      FmtJSON         -> multi "json"  pgf2json
      FmtPython       -> multi "py"  pgf2python
      FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
      FmtJava         -> multi "java" (grammar2java opts name)
@@ -57,9 +62,12 @@ exportPGF opts fmt pgf =
   multi :: String -> (PGF -> String) -> [(FilePath,String)]
   multi ext pr = [(name <.> ext, pr pgf)]

+-- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
+
   single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
   single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]

+
 -- | Get the name of the concrete syntax to generate output from.
 -- FIXME: there should be an option to change this.
 outputConcr :: PGF -> CId
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -25,7 +25,7 @@ import GF.Data.BacktrackM
 import GF.Data.Operations
 import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
 import GF.Data.Utilities (updateNthM) --updateNth
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Compile.Compute.Concrete(normalForm,resourceValues)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -41,6 +41,7 @@ import Control.Monad
 import Control.Monad.Identity
 --import Control.Exception
 --import Debug.Trace(trace)
+import qualified Control.Monad.Fail as Fail

 ----------------------------------------------------------------------
 -- main conversion function
@@ -81,7 +82,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
                          (goB b1 CNil [])
                          (pres,pargs)
      pmcfg      = getPMCFG pmcfgEnv1
-      
+
      stats      = let PMCFG prods funs = pmcfg
                       (s,e)            = bounds funs
                       !prods_cnt       = length prods
@@ -102,7 +103,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
          newArgs  = map getFIds newArgs'
      in addFunction env0 newCat fun newArgs

-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) 
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
                                                             mdef@(Just (L loc1 def))
                                                             mref@(Just (L loc2 ref))
                                                             mprn
@@ -161,7 +162,7 @@ pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
 pgfCncCat gr lincat index =
  let ((_,size),schema) = computeCatRange gr lincat
  in PGF.CncCat index (index+size-1)
-                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) 
+                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
                                    (getStrPaths schema)))
  where
    getStrPaths :: Schema Identity s c -> [Path]
@@ -196,6 +197,9 @@ newtype CnvMonad a = CM {unCM :: SourceGrammar
                              -> ([ProtoFCat],[Symbol])
                              -> Branch b}

+instance Fail.MonadFail CnvMonad where
+  fail = bug
+
 instance Applicative CnvMonad where
  pure = return
  (<*>) = ap
@@ -239,7 +243,7 @@ choices nr path = do (args,_) <- get
                                                                                                                    | (value,index) <- values])
    descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)

-    updateEnv path value gr c (args,seq) = 
+    updateEnv path value gr c (args,seq) =
      case updateNthM (restrictProtoFCat path value) nr args of
        Just args -> c value (args,seq)
        Nothing   -> bug "conflict in updateEnv"
@@ -602,7 +606,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do
                                                       Just index -> return (CPar (m,[(v,index)]))
                                                       Nothing    -> mzero
    addConstraint CNil             v (CStr _)      = bug "restrictProtoFCat: string path"
-    
+
    update k0 f [] = return []
    update k0 f (x@(k,Identity v):xs)
      | k0 == k    = do v <- f v
@@ -614,6 +618,23 @@ mkArray    lst = listArray (0,length lst-1) lst
 mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]

 bug msg = ppbug msg
-ppbug msg = error . render $ hang "Internal error in GeneratePMCFG:" 4 msg
+ppbug msg = error completeMsg
+ where
+  originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg
+  completeMsg =
+    case render msg of -- the error message for pattern matching a runtime string
+      "descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)"
+        -> unlines [originalMsg -- add more helpful output
+            ,""
+            ,"1) Check that you are not trying to pattern match a /runtime string/."
+            ,"   These are illegal:"
+            ,"     lin Test foo = case foo.s of {"
+            ,"                       \"str\" => … } ;   <- explicit matching argument of a lin"
+            ,"     lin Test foo = opThatMatches foo   <- calling an oper that pattern matches"
+            ,""
+            ,"2) Not about pattern matching? Submit a bug report and we update the error message."
+            ,"     https://github.com/GrammaticalFramework/gf-core/issues"
+            ]
+      _ -> originalMsg -- any other message: just print it as is

 ppU = ppTerm Unqualified
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -0,0 +1,439 @@
+-- | Translate grammars to Canonical form
+-- (a common intermediate representation to simplify export to other formats)
+module GF.Compile.GrammarToCanonical(
+       grammar2canonical,abstract2canonical,concretes2canonical,
+       projection,selection
+       ) 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 as G
+import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
+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,ident2raw,rawIdentS,showIdent,isWildIdent)
+import GF.Infra.Option(Options,optionsPGF)
+import PGF.Internal(Literal(..))
+import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
+import GF.Grammar.Canonical as C
+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
+    cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
+
+    funs = [FunDef (gId f) (convType ty) |
+            ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
+
+    adefs = allOrigInfos gr absname
+
+    convCtx = maybe [] (map convHypo . unLoc)
+    convHypo (bt,name,t) =
+      case typeForm t of
+        ([],(_,cat),[]) -> gId cat -- !!
+        tf -> error $ "abstract2canonical convHypo: " ++ show tf
+
+    convType t =
+      case typeForm t of
+        (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
+          where
+            bs = map convHypo' hyps
+            as = map convType args
+
+    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"
+           Ok cncmod = lookupModule gr cnc
+  ]
+
+-- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
+concrete2canonical gr cenv absname cnc modinfo =
+  Concrete (modId cnc) (modId absname) (convFlags gr cnc)
+      (neededParamTypes S.empty (params defs))
+      [lincat | (_,Left lincat) <- defs]
+      [lin | (_,Right lin) <- defs]
+  where
+    defs = concatMap (toCanonical gr absname cenv) .
+           M.toList $
+           jments modinfo
+
+    params = S.toList . S.unions . map fst
+
+    neededParamTypes have [] = []
+    neededParamTypes have (q:qs) =
+        if q `S.member` have
+        then neededParamTypes have qs
+        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 _ ->
+        [(pts,Left (LincatDef (gId name) (convType ntyp)))]
+      where
+        pts = paramTypes gr ntyp
+        ntyp = nf loc typ
+    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
+        [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
+      where
+        tts = tableTypes gr [e']
+
+        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
+
+    AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
+                     Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
+                     _ -> []
+    _ -> []
+  where
+    nf loc = normalForm cenv (L loc name)
+
+    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 =
+      case t of
+        V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
+        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)
+    Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
+    App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
+    Sort _ -> S.empty
+    EInt _ -> S.empty
+    Q q -> lookup q
+    QC q -> lookup q
+    FV ts -> S.unions (map (paramTypes gr) ts)
+    _ -> ignore
+  where
+    lookup q = case lookupOrigInfo gr q of
+                 Ok (_,ResOper  _ (Just (L _ t))) ->
+                                       S.insert q (paramTypes gr t)
+                 Ok (_,ResParam {}) -> S.singleton q
+                 _ -> ignore
+
+    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
+    ppTv vs' = convert' gr vs'
+
+    ppT t =
+      case t of
+--      Abs b x t -> ...
+--      V ty ts -> VTableValue (convType ty) (map ppT ts)
+        V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
+          where
+            Ok pts = allParamValues gr ty
+            Ok ps = mapM term2patt pts
+        T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
+        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 (sortRec r))
+        P t l -> projection (ppT t) (lblId l)
+        Vr x -> VarValue (gId x)
+        Cn x -> VarValue (gId x) -- hmm
+        Con c -> ParamConstant (Param (gId c) [])
+        Sort k -> VarValue (gId k)
+        EInt n -> LiteralValue (IntConstant n)
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
+        QC (m,n) -> ParamConstant (Param (gQId m n) [])
+        K s -> LiteralValue (StrConstant s)
+        Empty -> LiteralValue (StrConstant "")
+        FV ts -> VariantValue (map ppT ts)
+        Alts t' vs -> alts vs (ppT t')
+        _ -> error $ "convert' ppT: " ++ show t
+
+    ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
+
+    ppPredef n =
+      case predef n of
+        Ok BIND       -> p "BIND"
+        Ok SOFT_BIND  -> p "SOFT_BIND"
+        Ok SOFT_SPACE -> p "SOFT_SPACE"
+        Ok CAPIT      -> p "CAPIT"
+        Ok ALL_CAPIT  -> p "ALL_CAPIT"
+        _ -> VarValue (gQId cPredef n) -- hmm
+      where
+       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))
+        PR r -> RecordPattern (fields r) {-
+        PW -> WildPattern
+        PV x -> VarP x
+        PString s -> Lit (show s) -- !!
+        PInt i -> Lit (show i)
+        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)
+
+--  patToParam p = case ppP p of ParamPattern pv -> pv
+
+--  token s = single (c "TK" `Ap` lit s)
+
+    alts vs = PreValue (map alt vs)
+      where
+        alt (t,p) = (pre p,ppT0 t)
+
+        pre (K s) = [s]
+        pre Empty = [""]  -- Empty == K ""
+        pre (Strs ts) = concatMap pre ts
+        pre (EPatt p) = pat p
+        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 $ "convert' alts pat: "++show p
+
+    fields = map field . filter (not.isLockLabel.fst)
+    field (l,(_,t)) = RecordRow (lblId l) (ppT t)
+  --c = Const
+  --c = VarValue . VarValueId
+  --lit s = c (show s) -- hmm
+
+    ap f a = case f of
+               ParamConstant (Param p ps) ->
+                 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
+    (_,LiteralValue (StrConstant "")) -> v1
+    _ -> ConcatValue v1 v2
+
+-- | Smart constructor for projections
+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
+                          [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
+          [rv] -> rv
+          _ -> Selection (TableValue tt r') v
+      where
+        -- Don't introduce wildcard patterns, true to the canonical format,
+        -- annotate (or eliminate) rhs in impossible rows
+        r' = map trunc r
+        trunc r@(TableRow p e) = if mightMatchRow v r
+                                 then r
+                                 else TableRow p (impossible e)
+        {-
+        -- Creates smaller tables, but introduces wildcard patterns
+        r' = if null discard
+             then r
+             else keep++[TableRow WildPattern impossible]
+        -}
+        (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
+    ParamConstant (Param c1 pvs) ->
+      case p of
+        ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
+                                       and [mightMatch v p|(v,p)<-zip pvs pps]
+        _ -> False
+    RecordValue rv ->
+      case p of
+        RecordPattern 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 =
+      case t of
+        Table ti tv -> TableType (ppT ti) (ppT tv)
+        RecType rt -> RecordType (convFields rt)
+--      App tf ta -> TAp (ppT tf) (ppT ta)
+--      FV [] -> tcon0 (identS "({-empty variant-})")
+        Sort k -> convSort k
+--      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
+        FV (t:ts) -> ppT t -- !!
+        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
+        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
+        _ -> error $ "convType ppT: " ++ show t
+
+    convFields = map convField . filter (not.isLockLabel.fst)
+    convField (l,r) = RecordRow (lblId l) (ppT r)
+
+    convSort k = case showIdent k of
+                   "Float" -> FloatType
+                   "Int" -> IntType
+                   "Str" -> StrType
+                   _ -> error $ "convType convSort: " ++ show k
+
+toParamType :: Term -> ParamType
+toParamType t = case convType t of
+                  ParamType pt -> pt
+                  _ -> 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)) _)
+       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
+         ((S.singleton (m,n),argTypes ps),
+          [ParamDef name (map (param m) ps)]
+         )
+       where name = gQId m n
+      Ok (m,ResOper  _ (Just (L _ t)))
+        | m==cPredef && n==cInts ->
+           ((S.empty,S.empty),[]) {-
+           ((S.singleton (m,n),S.empty),
+            [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
+        | otherwise ->
+           ((S.singleton (m,n),paramTypes gr t),
+            [ParamAliasDef (gQId m n) (convType t)])
+      _ -> ((S.empty,S.empty),[])
+  where
+    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 :: Label -> C.LabelId
+lblId (LIdent ri) = LabelId ri
+lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
+
+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 (ident2raw i)
+
+instance FromIdent C.FunId where gId = C.FunId . ident2raw
+instance FromIdent CatId where gId = CatId . ident2raw
+instance FromIdent ParamId where gId = ParamId . unqual
+instance FromIdent VarValueId where gId = VarValueId . unqual
+
+class FromIdent i => QualIdent i where
+  gQId :: ModuleName -> Ident -> i
+
+instance QualIdent ParamId where gQId m n = ParamId (qual m n)
+instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
+
+qual :: ModuleName -> Ident -> QualId
+qual m n = Qual (modId m) (ident2raw n)
+
+unqual :: Ident -> QualId
+unqual n = Unqual (ident2raw n)
+
+convFlags :: G.Grammar -> ModuleName -> Flags
+convFlags gr mn =
+  Flags [(rawIdentS n,convLit v) |
+         (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
+  where
+    convLit l =
+      case l of
+        LStr s -> Str s
+        LInt i -> C.Int i
+        LFlt d -> Flt d
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -8,16 +8,13 @@ import GF.Compile.GenerateBC
 import PGF(CId,mkCId,utf8CId)
 import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
 import PGF.Internal(updateProductionIndices)
--import qualified PGF.Macros as CM
 import qualified PGF.Internal as C
 import qualified PGF.Internal as D
 import GF.Grammar.Predef
--import GF.Grammar.Printer
 import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look
 import qualified GF.Grammar as A
 import qualified GF.Grammar.Macros as GM
--import GF.Compile.GeneratePMCFG

 import GF.Infra.Ident
 import GF.Infra.Option
@@ -30,6 +27,7 @@ import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import Data.Array.IArray

+
 mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
 mkCanon2pgf opts gr am = do
  (an,abs) <- mkAbstr am
@@ -59,7 +57,9 @@ mkCanon2pgf opts gr am = do
              [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]

    mkConcr cm = do
-      let cflags  = err (const noOptions) mflags (lookupModule gr cm)
+      let cflags = err (const noOptions) mflags (lookupModule gr cm)
+          ciCmp | flag optCaseSensitive cflags = compare
+                | otherwise                    = C.compareCaseInsensitve

      (ex_seqs,cdefs) <- addMissingPMCFGs
                            Map.empty 
@@ -68,15 +68,15 @@ mkCanon2pgf opts gr am = do

      let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]

-          seqs = (mkSetArray . Set.fromList . concat) $
+          seqs = (mkArray . C.sortNubBy ciCmp . concat) $
                     (Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])

          ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence

          !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
          !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
-                                = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
-        
+                                = genCncFuns gr am cm ex_seqs_arr ciCmp seqs cdefs fid_cnt1 cnccats
+
          printnames = genPrintNames cdefs
      return (mi2i cm, D.Concr flags
                              printnames
@@ -186,6 +186,7 @@ genCncFuns :: Grammar
           -> ModuleName
           -> ModuleName
           -> Array SeqId Sequence
+           -> (Sequence -> Sequence -> Ordering)
           -> Array SeqId Sequence
           -> [(QIdent, Info)]
           -> FId
@@ -195,7 +196,7 @@ genCncFuns :: Grammar
               IntMap.IntMap [FunId],
               IntMap.IntMap [FunId],
               Array FunId D.CncFun)
-genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
+genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
@@ -282,9 +283,9 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
      in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs                                          
      where
        newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
-           
+
        binSearch v arr (i,j)
-          | i <= j    = case compare v (arr ! k) of
+          | i <= j    = case ciCmp v (arr ! k) of
                          LT -> binSearch v arr (i,k-1)
                          EQ -> k
                          GT -> binSearch v arr (k+1,j)
@@ -303,6 +304,5 @@ genPrintNames cdefs =
    flatten (Alts x _) = flatten x
    flatten (C x y)    = flatten x +++ flatten y

--mkArray    lst = listArray (0,length lst-1) lst
+mkArray    lst = listArray (0,length lst-1) lst
 mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-mkSetArray set = listArray (0,Set.size set-1) [v | v <- Set.toList set]
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -6,7 +6,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/09/16 13:56:13 $ 
+-- > CVS $Date: 2005/09/16 13:56:13 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.18 $
 --
@@ -21,23 +21,16 @@ import GF.Grammar.Printer
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
--import GF.Compile.Refresh
--import GF.Compile.Compute.Concrete
-import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
--import GF.Compile.CheckGrammar
--import GF.Compile.Update
-
+import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
 import GF.Data.Operations
--import GF.Infra.CheckM
 import GF.Infra.Option

 import Control.Monad
--import Data.List
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 import GF.Text.Pretty
 import Debug.Trace

-
 -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.

 optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule
@@ -54,7 +47,7 @@ optimizeModule opts sgr m@(name,mi)

   updateEvalInfo mi (i,info) = do
     info <- evalInfo oopts resenv sgr (name,mi) i info
-     return (mi{jments=updateTree (i,info) (jments mi)})
+     return (mi{jments=Map.insert i info (jments mi)})

 evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
 evalInfo opts resenv sgr m c info = do
@@ -97,7 +90,7 @@ evalInfo opts resenv sgr m c info = do
    let ppr' = fmap (evalPrintname resenv c) ppr
    return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
 {-
-  ResOper pty pde 
+  ResOper pty pde
    | not new && OptExpand `Set.member` optim -> do
         pde' <- case pde of
                   Just (L loc de) -> do de <- computeConcrete gr de
@@ -178,13 +171,13 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
     _ -> Bad (render ("linearization type field cannot be" <+> typ))

 mkLinReference :: SourceGrammar -> Type -> Err Term
-mkLinReference gr typ = 
- liftM (Abs Explicit varStr) $ 
+mkLinReference gr typ =
+ liftM (Abs Explicit varStr) $
   case mkDefField typ (Vr varStr) of
     Bad "no string" -> return Empty
     x               -> x
 where
-   mkDefField ty trm = 
+   mkDefField ty trm =
     case ty of
       Table pty ty -> do ps <- allParamValues gr pty
                          case ps of
@@ -210,7 +203,7 @@ factor param c i t =
    T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
    _               -> composSafeOp (factor param c i) t
  where
-    factors ty pvs0  
+    factors ty pvs0
                 | not param = V ty (map snd pvs0)
    factors ty []            = V ty []
    factors ty pvs0@[(p,v)]  = V ty [v]
@@ -231,7 +224,7 @@ factor param c i t =
 replace :: Term -> Term -> Term -> Term
 replace old new trm =
  case trm of
-    -- these are the important cases, since they can correspond to patterns  
+    -- these are the important cases, since they can correspond to patterns
    QC _     | trm == old -> new
    App _ _  | trm == old -> new
    R _      | trm == old -> new
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/src/compiler/GF/Compile/PGFtoHaskell.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Date: 2005/06/17 12:39:07 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.8 $
 --
@@ -22,54 +22,65 @@ 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
+type DerivingClause = String

 -- | the main function
 grammar2haskell :: Options
                -> String  -- ^ Module name.
                -> PGF
                -> String
-grammar2haskell opts name gr = foldr (++++) [] $  
-  pragmas ++ haskPreamble gadt name ++ [types, gfinstances gId lexical gr'] ++ compos
+grammar2haskell opts name gr = foldr (++++) [] $
+  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 = id
-              | otherwise = ("G"++)
-          pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}","{-# LANGUAGE GADTs #-}"]
+          gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
+              | otherwise = ("G"++) . rmForbiddenChars
+          -- GF grammars allow weird identifier names inside '', e.g. 'VP/Object'
+          rmForbiddenChars = filter (`notElem` "'!#$%&*+./<=>?@\\^|-~")
+          pragmas | gadt = ["{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"]
+                  | dataExt = ["{-# LANGUAGE DeriveDataTypeable #-}"]
                  | otherwise = []
+          derivingClause
+                 | dataExt = "deriving (Show,Data)"
+                 | otherwise = "deriving Show"
+          extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
+                       | dataExt = ["import Data.Data"]
+                       | otherwise = []
+          pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
+                     | otherwise = ["import PGF hiding (Tree)"]
          types | gadt = datatypesGADT gId lexical gr'
-                | otherwise = datatypes gId lexical gr'
+                | otherwise = datatypes gId derivingClause lexical gr'
          compos | gadt = prCompos gId lexical gr' ++ composClass
                 | otherwise = []

-haskPreamble gadt name =
+haskPreamble :: Bool -> String -> String -> [String] -> [String]
+haskPreamble gadt name derivingClause imports =
 [
  "module " ++ name ++ " where",
  ""
- ] ++
- (if gadt then [
-  "import Control.Monad.Identity",
-  "import Data.Monoid"
-  ] else []) ++
- [
-  "import PGF hiding (Tree)",
+ ] ++ imports ++ [
+  "",
  "----------------------------------------------------",
  "-- automatic translation from GF to Haskell",
  "----------------------------------------------------",
-  "", 
+  "",
  "class Gf a where",
  "  gf :: a -> Expr",
  "  fg :: Expr -> a",
  "",
-  predefInst gadt "GString" "String"  "unStr"    "mkStr",
+  predefInst gadt derivingClause "GString" "String"  "unStr"    "mkStr",
  "",
-  predefInst gadt "GInt"    "Int"     "unInt"    "mkInt",
+  predefInst gadt derivingClause "GInt"    "Int"     "unInt"    "mkInt",
  "",
-  predefInst gadt "GFloat"  "Double"  "unFloat"  "mkFloat",
+  predefInst gadt derivingClause "GFloat"  "Double"  "unFloat"  "mkFloat",
  "",
  "----------------------------------------------------",
  "-- below this line machine-generated",
@@ -77,11 +88,12 @@ haskPreamble gadt name =
  ""
 ]

-predefInst gadt gtyp typ destr consr = 
+predefInst :: Bool -> String -> String -> String -> String -> String -> String
+predefInst gadt derivingClause gtyp typ destr consr =
  (if gadt
-    then [] 
-    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show\n\n") 
-    ) 
+    then []
+    else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
+    )
  ++
  "instance Gf" +++ gtyp +++ "where" ++++
  "  gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
@@ -94,24 +106,24 @@ type OIdent = String

 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]

-datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd
+datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
+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 -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
-hDatatype _ _ ("Cn",_) = "" ---
-hDatatype gId _ (cat,[]) = "data" +++ gId cat
-hDatatype gId _ (cat,rules) | isListCat (cat,rules) = 
- "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" 
-  +++ "deriving Show"
-hDatatype gId lexical (cat,rules) =
+hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
+hDatatype _ _ _ ("Cn",_) = "" ---
+hDatatype gId _ _ (cat,[]) = "data" +++ gId cat
+hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) =
+ "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+  +++ derivingClause
+hDatatype gId derivingClause lexical (cat,rules) =
 "data" +++ gId cat +++ "=" ++
 (if length rules == 1 then "" else "\n  ") +++
 foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
- "  deriving Show"
+ " " +++ derivingClause
  where
    constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
                   ++ if lexical cat then [lexicalConstructor cat +++ "String"] else []
@@ -123,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
 lexicalConstructor :: OIdent -> String
 lexicalConstructor cat = "Lex" ++ cat

+predefTypeSkel :: HSkeleton
 predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]

 -- GADT version of data types
 datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypesGADT gId lexical (_,skel) = unlines $ 
+datatypesGADT gId lexical (_,skel) = unlines $
    concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
-    [ 
-      "", 
+    [
+      "",
      "data Tree :: * -> * where"
-    ] ++ 
+    ] ++
    concatMap (map ("  "++) . hDatatypeGADT gId lexical) skel ++
    [
      "  GString :: String -> Tree GString_",
@@ -156,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
       "data"+++gId cat++"_"]

 hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
-hDatatypeGADT gId lexical (cat, rules) 
+hDatatypeGADT gId lexical (cat, rules)
    | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
    | otherwise =
-        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t 
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
          | (f,args) <- nonLexicalRules (lexical cat) rules ]
        ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
  where t = "Tree" +++ gId cat ++ "_"

 hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
 hEqGADT gId lexical (cat, rules)
-  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] 
+  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
  | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
          ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []

 where
   patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
-   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | 
+   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
     (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
   listr c = (c,["foo"]) -- foo just for length = 1
   listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -181,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
 prCompos gId lexical (_,catrules) =
    ["instance Compos Tree where",
     "  compos r a f t = case t of"]
-    ++ 
+    ++
    ["    " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
-                                         (f,xs) <- rs, not (null xs)] 
-    ++ 
+                                         (f,xs) <- rs, not (null xs)]
+    ++
    ["    " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
-    ++ 
+    ++
    ["    _ -> r t"]
  where
-    prComposCons f xs = let vs = mkVars (length xs) in 
+    prComposCons f xs = let vs = mkVars (length xs) in
                        f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
    rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
-    prRec f (v,c) 
+    prRec f (v,c)
      | isList f  = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
      | otherwise = "`a`" +++ "f" +++ v
-    isList f = (gId "List") `isPrefixOf` f
+    isList f = gId "List" `isPrefixOf` f

 gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
 gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs

+hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
 ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
 hInstance gId _ m (cat,[]) = unlines [
  "instance Show" +++ gId cat,
@@ -208,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
  "  gf _ = undefined",
  "  fg _ = undefined"
  ]
-hInstance gId lexical m (cat,rules) 
+hInstance gId lexical m (cat,rules)
 | isListCat (cat,rules) =
  "instance Gf" +++ gId cat +++ "where" ++++
-     "  gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
+     "  gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
           +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
-     "  gf (" ++ gId cat +++ "(x:xs)) = " 
-           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] 
+     "  gf (" ++ gId cat +++ "(x:xs)) = "
+           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
 -- no show for GADTs
--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" 
+--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
 | otherwise =
  "instance Gf" +++ gId cat +++ "where\n" ++
  unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -225,19 +239,22 @@ hInstance gId lexical m (cat,rules)
   ec = elemCat cat
   baseVars = mkVars (baseSize (cat,rules))
   mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
-     (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
     "=" +++ mkRHS f xx'
-   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ 
-		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
+       "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"

+mkVars :: Int -> [String]
 mkVars = mkSVars "x"
+
+mkSVars :: String -> Int -> [String]
 mkSVars s n = [s ++ show i | i <- [1..n]]

 ----fInstance m ("Cn",_) = "" ---
 fInstance _ _ m (cat,[]) = ""
 fInstance gId lexical m (cat,rules) =
  "  fg t =" ++++
-  (if isList 
+  (if isList
    then "    " ++ gId cat ++ " (fgs t) where\n     fgs t = case unApp t of"
    else "    case unApp t of") ++++
  unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
@@ -249,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
     "      Just (i," ++
     "[" ++ prTList "," xx' ++ "])" +++
     "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
-       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
-	     mkRHS f vars 
-		 | isList =
-		     if "Base" `isPrefixOf` f 
-                       then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
-		       else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
-		 | otherwise = 
-		     gId f +++  
-		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
+       where
+         xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+         mkRHS f vars
+           | isList =
+               if "Base" `isPrefixOf` f
+                             then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+                 else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
+           | otherwise =
+               gId f +++
+               prTList " " [prParenth ("fg" +++ x) | x <- vars]

 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr = 
-  (showCId (absname gr), 
-   let fs = 
-         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | 
+hSkeleton gr =
+  (showCId (absname gr),
+   let fs =
+         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
                                        fs@((_, (_,c)):_) <- fns]
-   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
+   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
  )
 where
-   cts = Map.keys (cats (abstract gr)) 
+   cts = Map.keys (cats (abstract gr))
   fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
   valtyps (_, (_,x)) (_, (_,y)) = compare x y
   valtypg (_, (_,x)) (_, (_,y)) = x == y
@@ -283,9 +301,10 @@ updateSkeleton cat skel rule =
 -}
 isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
 isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
-		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
-    where c = elemCat cat
-	  fs = map fst rules
+        && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where
+      c = elemCat cat
+      fs = map fst rules

 -- | Gets the element category of a list category.
 elemCat :: OIdent -> OIdent
@@ -302,7 +321,7 @@ baseSize (_,rules) = length bs
    where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules

 composClass :: [String]
-composClass = 
+composClass =
    [
     "",
     "class Compos t where",
@@ -329,4 +348,3 @@ composClass =
     "",
     "newtype C b a = C { unC :: b }"
    ]
-
--- a/src/compiler/GF/Compile/PGFtoJSON.hs
+++ b/src/compiler/GF/Compile/PGFtoJSON.hs
@@ -0,0 +1,156 @@
+module GF.Compile.PGFtoJSON (pgf2json) where
+
+import PGF (showCId)
+import qualified PGF.Internal as M
+import PGF.Internal (
+  Abstr,
+  CId,
+  CncCat(..),
+  CncFun(..),
+  Concr,
+  DotPos,
+  Equation(..),
+  Literal(..),
+  PArg(..),
+  PGF,
+  Production(..),
+  Symbol(..),
+  Type,
+  absname,
+  abstract,
+  cflags,
+  cnccats,
+  cncfuns,
+  concretes,
+  funs,
+  productions,
+  sequences,
+  totalCats
+  )
+
+import qualified Text.JSON as JSON
+import Text.JSON (JSValue(..))
+
+import qualified Data.Array.IArray as Array
+import Data.Map (Map)
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+
+pgf2json :: PGF -> String
+pgf2json pgf =
+  JSON.encode $ JSON.makeObj
+    [ ("abstract", json_abstract)
+    , ("concretes", json_concretes)
+    ]
+ where
+   n  = showCId $ absname pgf
+   as = abstract pgf
+   cs = Map.assocs (concretes pgf)
+   start = showCId $ M.lookStartCat pgf
+   json_abstract = abstract2json n start as
+   json_concretes = JSON.makeObj $ map concrete2json cs
+
+abstract2json :: String -> String -> Abstr -> JSValue
+abstract2json name start ds =
+  JSON.makeObj
+    [ ("name", mkJSStr name)
+    , ("startcat", mkJSStr start)
+    , ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds)))
+    ]
+
+absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
+absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
+  where
+    (args,cat) = M.catSkeleton typ
+    sig = JSON.makeObj
+      [ ("args", JSArray $ map (mkJSStr.showCId) args)
+      , ("cat", mkJSStr $ showCId cat)
+      ]
+
+lit2json :: Literal -> JSValue
+lit2json (LStr s) = mkJSStr s
+lit2json (LInt n) = mkJSInt n
+lit2json (LFlt d) = JSRational True (toRational d)
+
+concrete2json :: (CId,Concr) -> (String,JSValue)
+concrete2json (c,cnc) = (showCId c,obj)
+  where
+    obj = JSON.makeObj
+      [ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ])
+      , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)])
+      , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
+      , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
+      , ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc)))
+      , ("totalfids", mkJSInt (totalCats cnc))
+      ]
+
+cats2json :: (CId, CncCat) -> (String,JSValue)
+cats2json (c,CncCat start end _) = (showCId c, ixs)
+  where
+    ixs = JSON.makeObj
+      [ ("start", mkJSInt start)
+      , ("end", mkJSInt end)
+      ]
+
+frule2json :: Production -> JSValue
+frule2json (PApply fid args) =
+  JSON.makeObj
+    [ ("type", mkJSStr "Apply")
+    , ("fid", mkJSInt fid)
+    , ("args", JSArray (map farg2json args))
+    ]
+frule2json (PCoerce arg) =
+  JSON.makeObj
+    [ ("type", mkJSStr "Coerce")
+    , ("arg", mkJSInt arg)
+    ]
+
+farg2json :: PArg -> JSValue
+farg2json (PArg hypos fid) =
+  JSON.makeObj
+    [ ("type", mkJSStr "PArg")
+    , ("hypos", JSArray $ map (mkJSInt . snd) hypos)
+    , ("fid", mkJSInt fid)
+    ]
+
+ffun2json :: CncFun -> JSValue
+ffun2json (CncFun f lins) =
+  JSON.makeObj
+    [ ("name", mkJSStr $ showCId f)
+    , ("lins", JSArray (map mkJSInt (Array.elems lins)))
+    ]
+
+seq2json :: Array.Array DotPos Symbol -> JSValue
+seq2json seq = JSArray [sym2json s | s <- Array.elems seq]
+
+sym2json :: Symbol -> JSValue
+sym2json (SymCat n l)    = new "SymCat" [mkJSInt n, mkJSInt l]
+sym2json (SymLit n l)    = new "SymLit" [mkJSInt n, mkJSInt l]
+sym2json (SymVar n l)    = new "SymVar" [mkJSInt n, mkJSInt l]
+sym2json (SymKS t)       = new "SymKS"  [mkJSStr t]
+sym2json (SymKP ts alts) = new "SymKP"  [JSArray (map sym2json ts), JSArray (map alt2json alts)]
+sym2json SymBIND         = new "SymKS"  [mkJSStr "&+"]
+sym2json SymSOFT_BIND    = new "SymKS"  [mkJSStr "&+"]
+sym2json SymSOFT_SPACE   = new "SymKS"  [mkJSStr "&+"]
+sym2json SymCAPIT        = new "SymKS"  [mkJSStr "&|"]
+sym2json SymALL_CAPIT    = new "SymKS"  [mkJSStr "&|"]
+sym2json SymNE           = new "SymNE"  []
+
+alt2json :: ([Symbol],[String]) -> JSValue
+alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
+
+new :: String -> [JSValue] -> JSValue
+new f xs =
+  JSON.makeObj
+    [ ("type", mkJSStr f)
+    , ("args", JSArray xs)
+    ]
+
+-- | Make JSON value from string
+mkJSStr :: String -> JSValue
+mkJSStr = JSString . JSON.toJSString
+
+-- | Make JSON value from integer
+mkJSInt :: Integral a => a -> JSValue
+mkJSInt = JSRational False . toRational
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.19 $
 --
@@ -23,23 +23,25 @@
 -----------------------------------------------------------------------------

 module GF.Compile.Rename (
-	       renameSourceTerm,
-	       renameModule
-	      ) where
+     renameSourceTerm,
+     renameModule
+    ) where

+import GF.Infra.Ident
+import GF.Infra.CheckM
 import GF.Grammar.Grammar
 import GF.Grammar.Values
 import GF.Grammar.Predef
-import GF.Infra.Ident
-import GF.Infra.CheckM
+import GF.Grammar.Lookup
 import GF.Grammar.Macros
 import GF.Grammar.Printer
--import GF.Grammar.Lookup
--import GF.Grammar.Printer
 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

 -- | this gives top-level access to renaming term input in the cc command
@@ -55,9 +57,9 @@ renameModule cwd gr mo@(m,mi) = do
  js     <- checkMapRecover (renameInfo cwd status mo) (jments mi)
  return (m, mi{jments = js})

-type Status = (StatusTree, [(OpenSpec, StatusTree)])
+type Status = (StatusMap, [(OpenSpec, StatusMap)])

-type StatusTree = BinTree Ident StatusInfo
+type StatusMap = Map.Map Ident StatusInfo

 type StatusInfo = Ident -> Term

@@ -66,25 +68,25 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env)

 -- Fails immediately on error, makes it possible to try other possibilities
 renameIdentTerm' :: Status -> Term -> Check Term
-renameIdentTerm' env@(act,imps) t0 = 
+renameIdentTerm' env@(act,imps) t0 =
  case t0 of
    Vr c -> ident predefAbs c
    Cn c -> ident (\_ s -> checkError s) c
    Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
    Q (m',c) -> do
      m <- lookupErr m' qualifs
-      f <- lookupTree showIdent c m
+      f <- lookupIdent c m
      return $ f c
    QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
    QC (m',c) -> do
      m <- lookupErr m' qualifs
-      f <- lookupTree showIdent c m
+      f <- lookupIdent c m
      return $ f c
    _ -> return t0
  where
    opens   = [st  | (OSimple _,st) <- imps]
-    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ 
-              [(m, st) | (OQualif _ m, st) <- imps] ++ 
+    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
+              [(m, st) | (OQualif _ m, st) <- imps] ++
              [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible

    -- this facility is mainly for BWC with GF1: you need not import PredefAbs
@@ -92,31 +94,41 @@ renameIdentTerm' env@(act,imps) t0 =
      | isPredefCat c = return (Q (cPredefAbs,c))
      | otherwise     = checkError s

-    ident alt c = 
-      case lookupTree showIdent c act of
-        Ok f -> return (f c)
-        _    -> case lookupTreeManyAll showIdent opens c of
-                  [f]  -> return (f c)
-                  []   -> alt c ("constant not found:" <+> c $$
-                                 "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                  fs   -> case nub [f c | f <- fs]  of
-                            [tr]     -> return tr
-{-
-                            ts       -> return $ AdHocOverload ts  
-                                        -- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014
-                                        -- the old definition is below and still presupposed in TypeCheck.Concrete
-}
-                            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
+    ident alt c =
+      case Map.lookup c act of
+        Just f -> return (f c)
+        _      -> case mapMaybe (Map.lookup c) opens of
+                    [f]  -> return (f c)
+                    []   -> alt c ("constant not found:" <+> c $$
+                                   "given" <+> fsep (punctuate ',' (map fst qualifs)))
+                    fs   -> case nub [f c | f <- fs]  of
+                              [tr]     -> return tr
+                              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 (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"]

-            -- a warning will be generated in CheckGrammar, and the head returned
-            -- in next V: 
-            -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 
+        -- 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
+info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
+info2status mq c i = case i of
  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
  ResValue _  -> maybe Con (curry QC) mq
  ResParam _ _  -> maybe Con (curry QC) mq
@@ -124,10 +136,10 @@ info2status mq (c,i) = case i of
  AnyInd False m -> maybe Cn (const (curry Q m)) mq
  _           -> maybe Cn (curry Q) mq

-tree2status :: OpenSpec -> BinTree Ident Info -> BinTree Ident StatusInfo
+tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap
 tree2status o = case o of
-  OSimple i   -> mapTree (info2status (Just i))
-  OQualif i j -> mapTree (info2status (Just j))
+  OSimple i   -> Map.mapWithKey (info2status (Just i))
+  OQualif i j -> Map.mapWithKey (info2status (Just j))

 buildStatus :: FilePath -> Grammar -> Module -> Check Status
 buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
@@ -136,16 +148,16 @@ buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
  ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
  let sts = map modInfo2status (exts++ops)
  return (if isModCnc mi
-            then (emptyBinTree,    reverse sts)  -- the module itself does not define any names
+            then (Map.empty,       reverse sts)  -- the module itself does not define any names
            else (self2status m mi,reverse sts)) -- so the empty ident is not needed

-modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusTree)
+modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap)
 modInfo2status (o,mo) = (o,tree2status o (jments mo))

-self2status :: ModuleName -> ModuleInfo -> StatusTree
-self2status c m = mapTree (info2status (Just c)) (jments m)
+self2status :: ModuleName -> ModuleInfo -> StatusMap
+self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
+

-  
 renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
 renameInfo cwd status (m,mi) i info =
  case info of
@@ -196,7 +208,7 @@ renameTerm env vars = ren vars where
    Abs b x t    -> liftM  (Abs b x) (ren (x:vs) t)
    Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
-    Vr x      
+    Vr x
      | elem x vs -> return trm
      | otherwise -> renid trm
    Cn _   -> renid trm
@@ -207,7 +219,7 @@ renameTerm env vars = ren vars where
      i' <- case i of
        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
        _ -> return i
-      liftM (T i') $ mapM (renCase vs) cs  
+      liftM (T i') $ mapM (renCase vs) cs

    Let (x,(m,a)) b -> do
      m' <- case m of
@@ -217,7 +229,7 @@ renameTerm env vars = ren vars where
      b' <- ren (x:vs) b
      return $ Let (x,(m',a')) b'

-    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either 
+    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either
                                                               -- record projection from variable or constant $r$ or qualified expression with module $r$
      | elem r vs -> return trm                                -- try var proj first ..
      | otherwise -> checks [ renid' (Q (MN r,label2ident l))      -- .. and qualified expression second.
@@ -244,7 +256,7 @@ renamePattern :: Status -> Patt -> Check (Patt,[Ident])
 renamePattern env patt =
    do r@(p',vs) <- renp patt
       let dupl = vs \\ nub vs
-       unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear:") 4
+       unless (null dupl) $ checkError (hang ("[C.4.13] Pattern is not linear. All variable names on the left-hand side must be distinct.") 4
                                             patt)
       return r
  where
@@ -319,7 +331,7 @@ renamePattern env patt =
 renameContext :: Status -> Context -> Check Context
 renameContext b = renc [] where
  renc vs cont = case cont of
-    (bt,x,t) : xts 
+    (bt,x,t) : xts
      | isWildIdent x -> do
          t'   <- ren vs t
          xts' <- renc vs xts
--- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/09/15 16:22:02 $ 
+-- > CVS $Date: 2005/09/15 16:22:02 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.16 $
 --
@@ -13,11 +13,11 @@
 -----------------------------------------------------------------------------

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

 import GF.Data.Operations

@@ -33,8 +33,8 @@ import GF.Text.Pretty
 --import Control.Monad (foldM, liftM, liftM2)

 -- | invariant way of creating TCEnv from context
-initTCEnv gamma = 
-  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) 
+initTCEnv gamma =
+  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)

 -- interface to TC type checker

--- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE PatternGuards #-}
-module GF.Compile.TypeCheck.Concrete( {-checkLType, inferLType, computeLType, ppType-} ) where
-{-
+module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
 import GF.Infra.CheckM
 import GF.Data.Operations

@@ -22,10 +23,16 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
    _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
      | isPredefConstant ty     -> return ty ---- shouldn't be needed

-    Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
+    Q (m,ident) -> checkIn ("module" <+> m) $ do
      ty' <- lookupResDef gr (m,ident)
      if ty' == ty then return ty else comp g ty' --- is this necessary to test?

+    AdHocOverload ts -> do
+     over <- getOverload gr g (Just typeType) t
+     case over of
+       Just (tr,_) -> return tr
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
+
    Vr ident  -> checkLookup ident g -- never needed to compute!

    App f a -> do
@@ -62,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
      lockRecType c t' ---- locking to be removed AR 20/6/2009

    _ | ty == typeTok -> return typeStr
-    _ | isPredefConstant ty -> return ty

    _ -> composOp (comp g) ty

@@ -73,26 +79,26 @@ inferLType gr g trm = case trm of

   Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
                                                Just ty -> return ty
-                                                Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
+                                                Nothing -> checkError ("unknown in Predef:" <+> ident)

   Q ident -> checks [
     termWith trm $ lookupResType gr ident >>= computeLType gr g
     ,
     lookupResDef gr ident >>= inferLType gr g
     ,
-     checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
+     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
     ]

   QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
                                                 Just ty -> return ty
-                                                 Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
+                                                 Nothing -> checkError ("unknown in Predef:" <+> ident)

   QC ident -> checks [
       termWith trm $ lookupResType gr ident >>= computeLType gr g
       ,
       lookupResDef gr ident >>= inferLType gr g
       ,
-       checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
+       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
       ]

   Vr ident -> termWith trm $ checkLookup ident g
@@ -100,7 +106,12 @@ inferLType gr g trm = case trm of
   Typed e t -> do
     t' <- computeLType gr g t
     checkLType gr g e t'
-     return (e,t')
+
+   AdHocOverload ts -> do
+     over <- getOverload gr g Nothing trm
+     case over of
+       Just trty -> return trty
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)

   App f a -> do
     over <- getOverload gr g Nothing trm
@@ -110,13 +121,17 @@ inferLType gr g trm = case trm of
         (f',fty) <- inferLType gr g f
         fty' <- computeLType gr g fty
         case fty' of
-           Prod bt z arg val -> do 
+           Prod bt z arg val -> do
             a' <- justCheck g a arg
-             ty <- if isWildIdent z 
+             ty <- if isWildIdent z
                      then return val
                      else substituteLType [(bt,z,a')] val
-             return (App f' a',ty) 
-           _ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty)
+             return (App f' a',ty)
+           _ ->
+             let term = ppTerm Unqualified 0 f
+                 funName = pp . head . words .render $ term
+              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
+                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")

   S f x -> do
     (f', fty) <- inferLType gr g f
@@ -124,7 +139,7 @@ inferLType gr g trm = case trm of
       Table arg val -> do
         x'<- justCheck g x arg
         return (S f' x', val)
-       _ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
+       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))

   P t i -> do
     (t',ty) <- inferLType gr g t   --- ??
@@ -132,16 +147,16 @@ inferLType gr g trm = case trm of
     let tr2 = P t' i
     termWith tr2 $ case ty' of
       RecType ts -> case lookup i ts of
-                       Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
+                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
                       Just x  -> return x
-       _          -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$
-                                 text " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
+       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
+                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')

   R r -> do
     let (ls,fs) = unzip r
     fsts <- mapM inferM fs
     let ts = [ty | (Just ty,_) <- fsts]
-     checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
+     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
     return $ (R (zip ls fsts), RecType (zip ls ts))

   T (TTyped arg) pts -> do
@@ -152,10 +167,10 @@ inferLType gr g trm = case trm of
     checkLType gr g trm (Table arg val)
   T ti pts -> do  -- tries to guess: good in oper type inference
     let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
-     case pts' of 
-       [] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm)
----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] 
-       _  -> do 
+     case pts' of
+       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
+----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
+       _  -> do
         (arg,val) <- checks $ map (inferCase Nothing) pts'
         checkLType gr g trm (Table arg val)
   V arg pts -> do
@@ -166,9 +181,9 @@ inferLType gr g trm = case trm of
   K s  -> do
     if elem ' ' s
        then do
-          let ss = foldr C Empty (map K (words s))  
+          let ss = foldr C Empty (map K (words s))
          ----- removed irritating warning AR 24/5/2008
-          ----- checkWarn ("token \"" ++ s ++ 
+          ----- checkWarn ("token \"" ++ s ++
          -----              "\" converted to token list" ++ prt ss)
          return (ss, typeStr)
        else return (trm, typeStr)
@@ -179,50 +194,56 @@ inferLType gr g trm = case trm of

   Empty -> return (trm, typeStr)

-   C s1 s2 -> 
+   C s1 s2 ->
     check2 (flip (justCheck g) typeStr) C s1 s2 typeStr

-   Glue s1 s2 -> 
+   Glue s1 s2 ->
     check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok

 ---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
   Strs (Cn c : ts) | c == cConflict -> do
-     checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
+     checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
     inferLType gr g (head ts)

   Strs ts -> do
-     ts' <- mapM (\t -> justCheck g t typeStr) ts 
+     ts' <- mapM (\t -> justCheck g t typeStr) ts
     return (Strs ts', typeStrs)

   Alts t aa -> do
     t'  <- justCheck g t typeStr
     aa' <- flip mapM aa (\ (c,v) -> do
-        c' <- justCheck g c typeStr 
+        c' <- justCheck g c typeStr
        v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
        return (c',v'))
     return (Alts t' aa', typeStr)

   RecType r -> do
     let (ls,ts) = unzip r
-     ts' <- mapM (flip (justCheck g) typeType) ts 
+     ts' <- mapM (flip (justCheck g) typeType) ts
     return (RecType (zip ls ts'), typeType)

   ExtR r s -> do
-     (r',rT) <- inferLType gr g r 
+
+---     over <- getOverload gr g Nothing r
+---     let r1 = maybe r fst over
+     let r1 = r ---
+
+     (r',rT) <- inferLType gr g r1
     rT'     <- computeLType gr g rT
+
     (s',sT) <- inferLType gr g s
     sT'     <- computeLType gr g sT

     let trm' = ExtR r' s'
-     ---- trm'    <- plusRecord r' s'
     case (rT', sT') of
       (RecType rs, RecType ss) -> do
-         rt <- plusRecType rT' sT'
+         let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
         checkLType gr g trm' rt ---- return (trm', rt)
-       _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
-       _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
+       _ | rT' == typeType && sT' == typeType -> do
+         return (trm', typeType)
+       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)

-   Sort _     -> 
+   Sort _     ->
     termWith trm $ return typeType

   Prod bt x a b -> do
@@ -231,7 +252,7 @@ inferLType gr g trm = case trm of
     return (Prod bt x a' b', typeType)

   Table p t  -> do
-     p' <- justCheck g p typeType --- check p partype! 
+     p' <- justCheck g p typeType --- check p partype!
     t' <- justCheck g t typeType
     return $ (Table p' t', typeType)

@@ -250,9 +271,9 @@ inferLType gr g trm = case trm of
   ELin c trm -> do
     (trm',ty) <- inferLType gr g trm
     ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
-     return $ (ELin c trm', ty') 
+     return $ (ELin c trm', ty')

-   _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
+   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)

 where
   isPredef m = elem m [cPredef,cPredefAbs]
@@ -299,7 +320,6 @@ inferLType gr g trm = case trm of
     PChars _ -> return $ typeStr
     _ -> inferLType gr g (patt2term p) >>= return . snd

-
 -- type inference: Nothing, type checking: Just t
 -- the latter permits matching with value type
 getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
@@ -310,15 +330,28 @@ getOverload gr g mt ot = case appForm ot of
         v <- matchOverload f typs ttys
         return $ Just v
       _ -> return Nothing
+     (AdHocOverload cs@(f:_), ts) -> do     --- the function name f is only used in error messages
+       let typs = concatMap collectOverloads cs
+       ttys <- mapM (inferLType gr g) ts
+       v <- matchOverload f typs ttys
+       return $ Just v
     _ -> return Nothing
+
 where
+   collectOverloads tr@(Q c) = case lookupOverload gr c of
+     Ok typs -> typs
+     _ -> case lookupResType gr c of
+       Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
+       _ -> []
+   collectOverloads _ = [] --- constructors QC
+
   matchOverload f typs ttys = do
     let (tts,tys) = unzip ttys
     let vfs = lookupOverloadInstance tys typs
     let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
     let showTypes ty = hsep (map ppType ty)

-    
+
     let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])

     -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
@@ -329,50 +362,57 @@ getOverload gr g mt ot = case appForm ot of
     case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
       ([(_,val,fun)],_) -> return (mkApp fun tts, val)
       ([],[(pre,val,fun)]) -> do
-         checkWarn $  text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
-                      text "for" $$
+         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
+                      "for" $$
                      nest 2 (showTypes tys) $$
-                      text "using" $$
+                      "using" $$
                      nest 2 (showTypes pre)
         return (mkApp fun tts, val)
       ([],[]) -> do
-         checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$
-                      text "for" $$
+         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
+                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
+                      "for argument list" $$
                      nest 2 stysError $$
-                      text "among" $$
-                      nest 2 (vcat stypsError) $$
-                      maybe empty (\x -> text "with value type" <+> ppType x) mt
+                      "among alternatives" $$
+                      nest 2 (vcat stypsError)
+

       (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
         ([(val,fun)],_) -> do
           return (mkApp fun tts, val)
         ([],[(val,fun)]) -> do
-           checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) 
+           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
           return (mkApp fun tts, val)

 ----- unsafely exclude irritating warning AR 24/5/2008
-----           checkWarn $ "overloading of" +++ prt f +++ 
+-----           checkWarn $ "overloading of" +++ prt f +++
 -----             "resolved by excluding partial applications:" ++++
 -----             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]

-
-         _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
-                           text "for" <+> hsep (map ppType tys) $$ 
-                           text "with alternatives" $$
-                           nest 2 (vcat [ppType ty | (_,ty,_) <- if null vfs1 then vfs2 else vfs2])
+--- now forgiving ambiguity with a warning AR 1/2/2014
+--  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
+--  But it also gives a chance to ambiguous overloadings that were banned before.
+         (nps1,nps2) -> do
+              checkWarn $  "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
+                  ----     "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
+                           "resolved by selecting the first of the alternatives" $$
+                           nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
+              case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
+                 [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
+                 h:_ -> return h

   matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]

   unlocked v = case v of
-     RecType fs -> RecType $ filter (not . isLockLabel . fst) fs
+     RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
     _ -> v
   ---- TODO: accept subtypes
   ---- TODO: use a trie
-   lookupOverloadInstance tys typs = 
-     [((pre,mkFunType rest val, t),isExact) | 
+   lookupOverloadInstance tys typs =
+     [((pre,mkFunType rest val, t),isExact) |
       let lt = length tys,
       (ty,(val,t)) <- typs, length ty >= lt,
-       let (pre,rest) = splitAt lt ty, 
+       let (pre,rest) = splitAt lt ty,
       let isExact = pre == tys,
       isExact || map unlocked pre == map unlocked tys
     ]
@@ -385,20 +425,21 @@ getOverload gr g mt ot = case appForm ot of

 checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
 checkLType gr g trm typ0 = do
-
  typ <- computeLType gr g typ0

  case trm of

    Abs bt x c -> do
      case typ of
-        Prod bt' z a b -> do 
+        Prod bt' z a b -> do
          (c',b') <- if isWildIdent z
                       then checkLType gr ((bt,x,a):g) c b
-                       else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b
+                       else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
                               checkLType gr ((bt,x,a):g) c b'
-          return $ (Abs bt x c', Prod bt' x a b')
-        _ -> checkError $ text "function type expected instead of" <+> ppType typ
+          return $ (Abs bt x c', Prod bt' z a b')
+        _ -> checkError $ "function type expected instead of" <+> ppType typ $$
+                          "\n   ** Double-check that the type signature of the operation" $$
+                          "matches the number of arguments given to it.\n"

    App f a -> do
       over <- getOverload gr g (Just typ) trm
@@ -408,6 +449,12 @@ checkLType gr g trm typ0 = do
          (trm',ty') <- inferLType gr g trm
          termWith trm' $ checkEqLType gr g typ ty' trm'

+    AdHocOverload ts -> do
+      over <- getOverload gr g Nothing trm
+      case over of
+        Just trty -> return trty
+        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
+
    Q _ -> do
       over <- getOverload gr g (Just typ) trm
       case over of
@@ -417,21 +464,21 @@ checkLType gr g trm typ0 = do
          termWith trm' $ checkEqLType gr g typ ty' trm'

    T _ [] ->
-      checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ)
-    T _ cs -> case typ of 
-      Table arg val -> do 
+      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
+    T _ cs -> case typ of
+      Table arg val -> do
        case allParamValues gr arg of
          Ok vs -> do
            let ps0 = map fst cs
            ps <- testOvershadow ps0 vs
-            if null ps 
-              then return () 
-              else checkWarn (text "patterns never reached:" $$
+            if null ps
+              then return ()
+              else checkWarn ("patterns never reached:" $$
                              nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
          _ -> return () -- happens with variable types
        cs' <- mapM (checkCase arg val) cs
        return (T (TTyped arg) cs', typ)
-      _ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType typ)
+      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
    V arg0 vs ->
      case typ of
        Table arg1 val ->
@@ -439,51 +486,54 @@ checkLType gr g trm typ0 = do
              vs1 <- allParamValues gr arg1
              if length vs1 == length vs
                 then return ()
-                 else checkError $ text "wrong number of values in table" <+> ppTerm Unqualified 0 trm
+                 else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
              vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
              return (V arg' vs',typ)

    R r -> case typ of --- why needed? because inference may be too difficult
       RecType rr -> do
-         let (ls,_) = unzip rr        -- labels of expected type
+       --let (ls,_) = unzip rr        -- labels of expected type
         fsts <- mapM (checkM r) rr   -- check that they are found in the record
         return $ (R fsts, typ)       -- normalize record

-       _ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
+       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))

    ExtR r s -> case typ of
       _ | typ == typeType -> do
         trm' <- computeLType gr g trm
         case trm' of
-           RecType _ -> termWith trm $ return typeType
-           ExtR (Vr _) (RecType _) -> termWith trm $ return typeType 
+           RecType _ -> termWith trm' $ return typeType
+           ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
                                      -- ext t = t ** ...
-           _ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
+           _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))

       RecType rr -> do
-         (r',ty,s') <- checks [
-            do (r',ty) <- inferLType gr g r
-               return (r',ty,s)
-           ,
-            do (s',ty) <- inferLType gr g s
-               return (s',ty,r)
-           ]

-         case ty of
-           RecType rr1 -> do
-                let (rr0,rr2) = recParts rr rr1
-                r2 <- justCheck g r' rr0
-                s2 <- justCheck g s' rr2
-                return $ (ExtR r2 s2, typ) 
-           _ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$
-                            text "but found" <+> ppTerm Unqualified 0 ty)
+         ll2 <- case s of
+           R ss -> return $ map fst ss
+           _ -> do
+             (s',typ2) <- inferLType gr g s
+             case typ2 of
+               RecType ss -> return $ map fst ss
+               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
+         let ll1 = [l | (l,_) <- rr, notElem l ll2]
+
+---         over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020
+---         let r1 = maybe r fst over
+         let r1 = r ---
+
+         (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1])
+         (s',_) <- checkLType gr g s  (RecType [field | field@(l,_) <- rr, elem l ll2])
+
+         let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2])
+         return (rec, typ)

       ExtR ty ex -> do
         r' <- justCheck g r ty
         s' <- justCheck g s ex
         return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ

-       _ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
+       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)

    FV vs -> do
      ttys <- mapM (flip (checkLType gr g) typ) vs
@@ -498,7 +548,7 @@ checkLType gr g trm typ0 = do
          (arg',val) <- checkLType gr g arg p
          checkEqLType gr g typ t trm
          return (S tab' arg', t)
-        _ -> checkError (text "table type expected for applied table instead of" <+> ppType ty')
+        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
     , do
      (arg',ty) <- inferLType gr g arg
      ty'       <- computeLType gr g ty
@@ -507,7 +557,8 @@ checkLType gr g trm typ0 = do
      ]
    Let (x,(mty,def)) body -> case mty of
      Just ty -> do
-        (def',ty') <- checkLType gr g def ty
+        (ty0,_)    <- checkLType gr g ty typeType
+        (def',ty') <- checkLType gr g def ty0
        body' <- justCheck ((Explicit,x,ty'):g) body typ
        return (Let (x,(Just ty',def')) body', typ)
      _ -> do
@@ -523,10 +574,10 @@ checkLType gr g trm typ0 = do
      termWith trm' $ checkEqLType gr g typ ty' trm'
 where
   justCheck g ty te = checkLType gr g ty te >>= return . fst
-
-   recParts rr t = (RecType rr1,RecType rr2) where 
-     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr 
-
+{-
+   recParts rr t = (RecType rr1,RecType rr2) where
+     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr
+-}
   checkM rms (l,ty) = case lookup l rms of
     Just (Just ty0,t) -> do
       checkEqLType gr g ty ty0 t
@@ -535,12 +586,12 @@ checkLType gr g trm typ0 = do
     Just (_,t) -> do
       (t',ty') <- checkLType gr g t ty
       return (l,(Just ty',t'))
-     _ -> checkError $ 
-            if isLockLabel l 
+     _ -> checkError $
+            if isLockLabel l
              then let cat = drop 5 (showIdent (label2ident l))
-                   in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <> 
-                      text "; try wrapping it with lin" <+> text cat
-              else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms)
+                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
+                      "; try wrapping it with lin" <+> cat
+              else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)

   checkCase arg val (p,t) = do
     cont <- pattContext gr g arg p
@@ -553,7 +604,7 @@ pattContext env g typ p = case p of
  PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
    t <- lookupResType env (q,c)
    let (cont,v) = typeFormCnc t
-    checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
+    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
              (length cont == length ps)
    checkEqLType env g typ v (patt2term p)
    mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
@@ -564,7 +615,7 @@ pattContext env g typ p = case p of
        let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
        ----- checkWarn $ prt p ++++ show pts ----- debug
        mapM (uncurry (pattContext env g)) pts >>= return . concat
-      _ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
+      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
  PT t p' -> do
    checkEqLType env g typ t (patt2term p')
    pattContext env g typ p'
@@ -577,10 +628,10 @@ pattContext env g typ p = case p of
    g1 <- pattContext env g typ p'
    g2 <- pattContext env g typ q
    let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
-    checkCond 
-      (text "incompatible bindings of" <+>
-       fsep (map ppIdent pts) <+> 
-       text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) 
+    checkCond
+      ("incompatible bindings of" <+>
+       fsep pts <+>
+       "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
    return g1 -- must be g1 == g2
  PSeq p q -> do
    g1 <- pattContext env g typ p
@@ -590,11 +641,11 @@ pattContext env g typ p = case p of
  PNeg p' -> noBind typ p'

  _ -> return [] ---- check types!
- where 
+ where
   noBind typ p' = do
    co <- pattContext env g typ p'
    if not (null co)
-      then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p) 
+      then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
           >> return []
      else return []

@@ -603,9 +654,31 @@ checkEqLType gr g t u trm = do
  (b,t',u',s) <- checkIfEqLType gr g t u trm
  case b of
    True  -> return t'
-    False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$
-                          text "expected:" <+> ppType t $$
-                          text "inferred:" <+> ppType u
+    False ->
+      let inferredType = ppTerm Qualified 0 u
+          expectedType = ppTerm Qualified 0 t
+          term = ppTerm Unqualified 0 trm
+          funName = pp . head . words .render $ term
+          helpfulMsg =
+            case (arrows inferredType, arrows expectedType) of
+              (0,0) -> pp "" -- None of the types is a function
+              _ -> "\n   **" <+>
+                  if expectedType `isLessApplied` inferredType
+                    then "Maybe you gave too few arguments to" <+> funName
+                    else pp "Double-check that type signature and number of arguments match."
+      in checkError $ s <+> "type of" <+> term $$
+                            "expected:" <+> expectedType $$ -- ppqType t u $$
+                            "inferred:" <+> inferredType $$ -- ppqType u t
+                            helpfulMsg
+  where
+    -- count the number of arrows in the prettyprinted term
+    arrows :: Doc -> Int
+    arrows = length . filter (=="->") . words . render
+
+    -- If prettyprinted type t has fewer arrows then prettyprinted type u,
+    -- then t is "less applied", and we can print out more helpful error msg.
+    isLessApplied :: Doc -> Doc -> Bool
+    isLessApplied t u = arrows t < arrows u

 checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
 checkIfEqLType gr g t u trm = do
@@ -617,60 +690,62 @@ checkIfEqLType gr g t u trm = do
    --- better: use a flag to forgive? (AR 31/1/2006)
    _ -> case missingLock [] t' u' of
      Ok lo -> do
-        checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo)
+        checkWarn $ "missing lock field" <+> fsep lo
        return (True,t',u',[])
      Bad s -> return (False,t',u',s)

  where

-   -- t is a subtype of u 
+   -- check that u is a subtype of t
   --- quick hack version of TC.eqVal
-   alpha g t u = case (t,u) of  
+   alpha g t u = case (t,u) of

     -- error (the empty type!) is subtype of any other type
     (_,u) | u == typeError -> True

     -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d 
-                              
+     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
+
     -- record subtyping
-     (RecType rs, RecType ts) -> all (\ (l,a) -> 
-                                   any (\ (k,b) -> alpha g a b && l == k) ts) rs
+     (RecType rs, RecType ts) -> all (\ (l,a) ->
+                                   any (\ (k,b) -> l == k && alpha g a b) ts) rs
     (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
     (ExtR r s, t) -> alpha g r t || alpha g s t

     -- the following say that Ints n is a subset of Int and of Ints m >= n
-     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n
+     -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
+     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
           | Just _ <- isTypeInts t, u == typeInt           -> True ---- check size!
           | t == typeInt,           Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005

     ---- this should be made in Rename
-     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                   || elem n (allExtendsPlus gr m)
                                   || m == n --- for Predef
-     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                   || elem n (allExtendsPlus gr m)
-     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                   || elem n (allExtendsPlus gr m)
-     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                   || elem n (allExtendsPlus gr m)

-     (Table a b,  Table c d)  -> alpha g a c && alpha g b d
+     -- contravariance
+     (Table a b,  Table c d)  -> alpha g c a && alpha g b d
     (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
-     _                        -> t == u 
+     _                        -> t == u
     --- the following should be one-way coercions only. AR 4/1/2001
                                  || elem t sTypes && elem u sTypes
-                                  || (t == typeType && u == typePType) 
-                                  || (u == typeType && t == typePType) 
+                                  || (t == typeType && u == typePType)
+                                  || (u == typeType && t == typePType)

-   missingLock g t u = case (t,u) of  
-     (RecType rs, RecType ts) -> 
-       let 
-         ls = [l | (l,a) <- rs, 
+   missingLock g t u = case (t,u) of
+     (RecType rs, RecType ts) ->
+       let
+         ls = [l | (l,a) <- rs,
                   not (any (\ (k,b) -> alpha g a b && l == k) ts)]
         (locks,others) = partition isLockLabel ls
       in case others of
-         _:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others)))
+         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
         _ -> return locks
     -- contravariance
     (Prod _ x a b, Prod _ y c d) -> do
@@ -696,7 +771,7 @@ termWith t ct = do
  return (t,ty)

 -- | compositional check\/infer of binary operations
-check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> 
+check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
          Term -> Term -> Type -> Check (Term,Type)
 check2 chk con a b t = do
  a' <- chk a
@@ -708,14 +783,18 @@ ppType :: Type -> Doc
 ppType ty =
  case ty of
    RecType fs   -> case filter isLockLabel $ map fst fs of
-                      [lock] -> text (drop 5 (showIdent (label2ident lock)))
+                      [lock] -> pp (drop 5 (showIdent (label2ident lock)))
                      _      -> ppTerm Unqualified 0 ty
-    Prod _ x a b -> ppType a <+> text "->" <+> ppType b
+    Prod _ x a b -> ppType a <+> "->" <+> ppType b
    _            -> ppTerm Unqualified 0 ty
-
+{-
+ppqType :: Type -> Type -> Doc
+ppqType t u = case (ppType t, ppType u) of
+  (pt,pu) | render pt == render pu -> ppTerm Qualified 0 t
+  (pt,_) -> pt
+-}
 checkLookup :: Ident -> Context -> Check Type
 checkLookup x g =
  case [ty | (b,y,ty) <- g, x == y] of
-    []     -> checkError (text "unknown variable" <+> ppIdent x)
+    []     -> checkError ("unknown variable" <+> x)
    (ty:_) -> return ty
-}
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module GF.Compile.TypeCheck.ConcreteNew( checkLType, inferLType ) where

 -- The code here is based on the paper:
@@ -9,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
@@ -19,6 +20,7 @@ import GF.Text.Pretty
 import Data.List (nub, (\\), tails)
 import qualified Data.IntMap as IntMap
 import Data.Maybe(fromMaybe,isNothing)
+import qualified Control.Monad.Fail as Fail

 checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type)
 checkLType ge t ty = runTcM $ do
@@ -131,7 +133,7 @@ tcRho ge scope t@(RecType rs) (Just ty) = do
                         [] -> unifyVar ge scope i env vs vtypePType
                         _  -> return ()
    ty              -> do ty <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) ty
-                          tcError ("The record type" <+> ppTerm Unqualified 0 t $$ 
+                          tcError ("The record type" <+> ppTerm Unqualified 0 t $$
                                   "cannot be of type" <+> ppTerm Unqualified 0 ty)
  (rs,mb_ty) <- tcRecTypeFields ge scope rs (Just ty')
  return (f (RecType rs),ty)
@@ -185,7 +187,7 @@ tcRho ge scope (R rs) (Just ty) = do
  case ty' of
    (VRecType ltys) -> do lttys <- checkRecFields ge scope rs ltys
                          rs <- mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
-                          return ((f . R)  rs, 
+                          return ((f . R)  rs,
                                  VRecType [(l, ty) | (l,t,ty) <- lttys]
                                 )
    ty              -> do lttys <- inferRecFields ge scope rs
@@ -275,11 +277,11 @@ tcApp ge scope (App fun arg) =                                  -- APP2
        varg <- liftErr (eval ge (scopeEnv scope) arg)
        return (App fun arg, res_ty varg)
 tcApp ge scope (Q id) =                                          -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> 
+  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
     do ty <- liftErr (eval ge [] ty)
        return (t,ty)
 tcApp ge scope (QC id) =                                         -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> 
+  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
     do ty <- liftErr (eval ge [] ty)
        return (t,ty)
 tcApp ge scope t =
@@ -348,7 +350,7 @@ tcPatt ge scope (PM q) ty0 = do
    Bad err -> tcError (pp err)
 tcPatt ge scope p ty = unimplemented ("tcPatt "++show p)

-inferRecFields ge scope rs = 
+inferRecFields ge scope rs =
  mapM (\(l,r) -> tcRecField ge scope l r Nothing) rs

 checkRecFields ge scope []          ltys
@@ -366,7 +368,7 @@ checkRecFields ge scope ((l,t):lts) ltys =
  where
    takeIt l1 []  = (Nothing, [])
    takeIt l1 (lty@(l2,ty):ltys)
-      | l1 == l2  = (Just ty,ltys) 
+      | l1 == l2  = (Just ty,ltys)
      | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
                    in (mb_ty,lty:ltys')

@@ -388,13 +390,13 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
               | s == cPType -> return mb_ty
             VMeta _ _ _     -> return mb_ty
             _               -> do sort <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) sort
-                                   tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$ 
+                                   tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
                                            "cannot be of type" <+> ppTerm Unqualified 0 sort)
  (rs,mb_ty) <- tcRecTypeFields ge scope rs mb_ty
  return ((l,ty):rs,mb_ty)

 -- | Invariant: if the third argument is (Just rho),
-- 	            then rho is in weak-prenex form
+--              then rho is in weak-prenex form
 instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
 instSigma ge scope t ty1 Nothing    = return (t,ty1)           -- INST1
 instSigma ge scope t ty1 (Just ty2) = do                       -- INST2
@@ -442,11 +444,11 @@ subsCheckRho ge scope t (VApp p1 _) (VApp p2 _)                         -- Rule
  | predefName p1 == cInts && predefName p2 == cInt = return t
 subsCheckRho ge scope t (VApp p1 [VInt i]) (VApp p2 [VInt j])           -- Rule INT2
  | predefName p1 == cInts && predefName p2 == cInts =
-      if i <= j 
+      if i <= j
        then return t
        else tcError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
 subsCheckRho ge scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
-  let mkAccess scope t = 
+  let mkAccess scope t =
        case t of
          ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
                           (scope,mkProj2,mkWrap2) <- mkAccess scope t2
@@ -555,7 +557,7 @@ unify ge scope v (VMeta i env vs) = unifyVar ge scope i env vs v
 unify ge scope v1 v2 = do
  t1 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v1
  t2 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v2
-  tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$ 
+  tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$
                                      ppTerm Unqualified 0 t2))

 -- | Invariant: tv1 is a flexible type variable
@@ -566,9 +568,9 @@ unifyVar ge scope i env vs ty2 = do            -- Check whether i is bound
    Bound ty1       -> do v <- liftErr (eval ge env ty1)
                          unify ge scope (vapply (geLoc ge) v vs) ty2
    Unbound scope' _ -> case value2term (geLoc ge) (scopeVars scope') ty2 of
-                          Left i     -> let (v,_) = reverse scope !! i
-                                        in tcError ("Variable" <+> pp v <+> "has escaped")
-                          Right ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
+                          -- Left i     -> let (v,_) = reverse scope !! i
+                          --               in tcError ("Variable" <+> pp v <+> "has escaped")
+                                ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
                                           if i `elem` ms2
                                             then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
                                                           nest 2 (ppTerm Unqualified 0 ty2'))
@@ -607,7 +609,7 @@ quantify ge scope t tvs ty0 = do
  ty <- tc_value2term (geLoc ge) (scopeVars scope) ty0
  let used_bndrs = nub (bndrs ty)  -- Avoid quantified type variables in use
      new_bndrs  = take (length tvs) (allBinders \\ used_bndrs)
-  mapM_ bind (tvs `zip` new_bndrs)   -- 'bind' is just a cunning way 
+  mapM_ bind (tvs `zip` new_bndrs)   -- 'bind' is just a cunning way
  ty <- zonkTerm ty                  -- of doing the substitution
  vty <- liftErr (eval ge [] (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs))
  return (foldr (Abs Implicit) t new_bndrs,vty)
@@ -617,7 +619,7 @@ quantify ge scope t tvs ty0 = do
    bndrs (Prod _ x t1 t2) = [x] ++ bndrs t1  ++ bndrs t2
    bndrs _                = []

-allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,... 
+allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,...
 allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
             [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]

@@ -629,8 +631,8 @@ allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
 type Scope = [(Ident,Value)]

 type Sigma = Value
-type Rho   = Value	-- No top-level ForAll
-type Tau   = Value	-- No ForAlls anywhere
+type Rho   = Value -- No top-level ForAll
+type Tau   = Value -- No ForAlls anywhere

 data MetaValue
  = Unbound Scope Sigma
@@ -646,8 +648,16 @@ instance Monad TcM where
  f >>= g  = TcM (\ms msgs -> case unTcM f ms msgs of
                                TcOk x ms msgs -> unTcM (g x) ms msgs
                                TcFail    msgs -> TcFail msgs)
+
+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail TcM where
  fail     = tcError . pp

+
 instance Applicative TcM where
  pure = return
  (<*>) = ap
@@ -678,12 +688,12 @@ runTcM f = case unTcM f IntMap.empty [] of
             TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg

 newMeta :: Scope -> Sigma -> TcM MetaId
-newMeta scope ty = TcM (\ms msgs -> 
+newMeta scope ty = TcM (\ms msgs ->
  let i = IntMap.size ms
  in TcOk i (IntMap.insert i (Unbound scope ty) ms) msgs)

 getMeta :: MetaId -> TcM MetaValue
-getMeta i = TcM (\ms msgs -> 
+getMeta i = TcM (\ms msgs ->
  case IntMap.lookup i ms of
    Just mv -> TcOk mv ms msgs
    Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs))
@@ -692,7 +702,7 @@ setMeta :: MetaId -> MetaValue -> TcM ()
 setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)

 newVar :: Scope -> Ident
-newVar scope = head [x | i <- [1..], 
+newVar scope = head [x | i <- [1..],
                         let x = identS ('v':show i),
                         isFree scope x]
  where
@@ -711,11 +721,11 @@ getMetaVars loc sc_tys = do
  return (foldr go [] tys)
  where
    -- Get the MetaIds from a term; no duplicates in result
-    go (Vr tv)    acc = acc 
+    go (Vr tv)    acc = acc
    go (App x y)  acc = go x (go y acc)
    go (Meta i)   acc
-	  | i `elem` acc  = acc
-	  | otherwise	  = i : acc
+      | i `elem` acc  = acc
+      | otherwise     = i : acc
    go (Q _)      acc = acc
    go (QC _)     acc = acc
    go (Sort _)   acc = acc
@@ -731,10 +741,10 @@ getFreeVars loc sc_tys = do
  tys <- mapM (\(scope,ty) -> zonkTerm =<< tc_value2term loc (scopeVars scope) ty) sc_tys
  return (foldr (go []) [] tys)
  where
-    go bound (Vr tv)            acc 
-	  | tv `elem` bound             = acc
-	  | tv `elem` acc               = acc
-	  | otherwise                   = tv : acc
+    go bound (Vr tv)            acc
+      | tv `elem` bound             = acc
+      | tv `elem` acc               = acc
+      | otherwise                   = tv : acc
    go bound (App x y)          acc = go bound x (go bound y acc)
    go bound (Meta _)           acc = acc
    go bound (Q _)              acc = acc
@@ -755,13 +765,13 @@ zonkTerm (Meta i) = do
 zonkTerm t = composOp zonkTerm t

 tc_value2term loc xs v =
-  case value2term loc xs v of
-    Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
-    Right t -> return t
+  return $ value2term loc xs v
+    -- Old value2term error message:
+    -- Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")



-data TcA x a 
+data TcA x a
  = TcSingle   (MetaStore -> [Message] -> TcResult a)
  | TcMany [x] (MetaStore -> [Message] -> [(a,MetaStore,[Message])])

--- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
@@ -1,761 +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) 
-           _ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty)
-
-   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
-     (r',rT) <- inferLType gr g r 
-     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 Unqualified 0 f $$
-                      "for" $$
-                      nest 2 stysError $$
-                      "among" $$
-                      nest 2 (vcat stypsError) $$
-                      maybe empty (\x -> "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 ("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) 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
-
-    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]
-         (r',_) <- checkLType gr g r (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 -> checkError $ s <+> "type of" <+> ppTerm Unqualified 0 trm $$
-                          "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
-                          "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
-
-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
--- a/src/compiler/GF/Compile/TypeCheck/TC.hs
+++ b/src/compiler/GF/Compile/TypeCheck/TC.hs
@@ -5,21 +5,22 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/10/02 20:50:19 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.11 $
 --
 -- Thierry Coquand's type checking algorithm that creates a trace
 -----------------------------------------------------------------------------

-module GF.Compile.TypeCheck.TC (AExp(..),
-	   Theory,
-	   checkExp,
-	   inferExp,
-	   checkBranch,
-	   eqVal,
-	   whnf
-	  ) where
+module GF.Compile.TypeCheck.TC (
+    AExp(..),
+    Theory,
+    checkExp,
+    inferExp,
+    checkBranch,
+    eqVal,
+    whnf
+  ) where

 import GF.Data.Operations
 import GF.Grammar
@@ -31,17 +32,17 @@ import Data.Maybe
 import GF.Text.Pretty

 data AExp =
-     AVr   Ident Val 
+     AVr   Ident Val
   | ACn   QIdent Val
-   | AType 
-   | AInt  Int 
+   | AType
+   | AInt  Int
   | AFloat Double
   | AStr  String
   | AMeta MetaId Val
   | ALet  (Ident,(Val,AExp)) AExp
-   | AApp  AExp AExp Val 
-   | AAbs  Ident Val AExp 
-   | AProd Ident AExp AExp 
+   | AApp  AExp AExp Val
+   | AAbs  Ident Val AExp
+   | AProd Ident AExp AExp
 -- -- | AEqs  [([Exp],AExp)] --- not used
   | ARecType [ALabelling]
   | AR    [AAssign]
@@ -50,7 +51,7 @@ data AExp =
   | AData Val
  deriving (Eq,Show)

-type ALabelling = (Label, AExp) 
+type ALabelling = (Label, AExp)
 type AAssign = (Label, (Val, AExp))

 type Theory = QIdent -> Err Val
@@ -71,7 +72,7 @@ whnf :: Val -> Err Val
 whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
         case v of
  VApp u w -> do
-    u' <- whnf u 
+    u' <- whnf u
    w' <- whnf w
    app u' w'
  VClos env e -> eval env e
@@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val
 app u v = case u of
  VClos env (Abs _ x e) -> eval ((x,v):env) e
  _ -> return $ VApp u v
-  
+
 eval :: Env -> Term -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ 
+eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
             case e of
  Vr x    -> lookupVar env x
  Q c   -> return $ VCn c
@@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
  _ -> return $ VClos env e

 eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ 
+eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
                do
  w1 <- whnf u1
-  w2 <- whnf u2 
+  w2 <- whnf u2
  let v = VGen k
  case (w1,w2) of
    (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
    (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
      eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
    (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
-      liftM2 (++) 
+      liftM2 (++)
        (eqVal k     (VClos            env1  a1) (VClos            env2  a2))
        (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
    (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
-    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] 
+    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
    --- thus ignore qualifications; valid because inheritance cannot
-    --- be qualified. Simplifies annotation. AR 17/3/2005 
+    --- be qualified. Simplifies annotation. AR 17/3/2005
    _ -> return [(w1,w2) | w1 /= w2]
 -- invariant: constraints are in whnf

@@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do

    Abs _ x t -> case typ of
      VClos env (Prod _ y a b) -> do
-	a' <- whnf $ VClos env a ---
-	(t',cs) <- checkExp th 
-                           (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
-	return (AAbs x a' t', cs)
+                           a' <- whnf $ VClos env a ---
+                           (t',cs) <- checkExp th
+                                          (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+                           return (AAbs x a' t', cs)
      _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))

    Let (x, (mb_typ, e1)) e2 -> do
@@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
      (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
      return (AProd x a' b', csa ++ csb)

-    R xs -> 
+    R xs ->
      case typ of
        VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
                            [] -> return ()
@@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
  (e',w,cs1) <- inferExp th tenv e
  cs2 <- eqVal k w typ
  return (e',cs1 ++ cs2)
-      
+
 inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
 inferExp th tenv@(k,rho,gamma) e = case e of
   Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
@@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of
    (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
    return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
   App f t -> do
-    (f',w,csf) <- inferExp th tenv f 
+    (f',w,csf) <- inferExp th tenv f
    typ <- whnf w
    case typ of
      VClos env (Prod _ x a b) -> do
        (a',csa) <- checkExp th tenv t (VClos env a)
-	b' <- whnf $ VClos ((x,VClos rho t):env) b
-	return $ (AApp f' a' b', b', csf ++ csa)
+        b' <- whnf $ VClos ((x,VClos rho t):env) b
+        return $ (AApp f' a' b', b', csf ++ csa)
      _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
   _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))

@@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
                   return ((lbl,(val,aexp)),cs)

 checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ 
-                                  chB tenv' ps' ty 
- where 
+checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
+                                  chB tenv' ps' ty
+ where

  (ps',_,rho2,k') = ps2ts k ps
  tenv' = (k, rho2++rho, gamma) ---- k' ?
@@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
      typ <- whnf ty
      case typ of
        VClos env (Prod _ y a b) -> do
-	  a' <- whnf $ VClos env a
+          a' <- whnf $ VClos env a
          (p', sigma, binds, cs1) <- checkP tenv p y a'
          let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
          ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
-	  return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
+          return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
        _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
    [] -> do
      (e,cs) <- checkExp th tenv t ty
@@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
     let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
     return (VClos sigma t, sigma, delta, cs)

-  ps2ts k = foldr p2t ([],0,[],k) 
+  ps2ts k = foldr p2t ([],0,[],k)
  p2t p (ps,i,g,k) = case p of
-     PW      -> (Meta i : ps, i+1,g,k) 
+     PW      -> (Meta i : ps, i+1,g,k)
     PV x    -> (Vr x   : ps, i, upd x k g,k+1)
     PAs x p -> p2t p (ps,i,g,k)
     PString s -> (K s : ps, i, g, k)
     PInt n -> (EInt n : ps, i, g, k)
     PFloat n -> (EFloat n : ps, i, g, k)
-     PP c xs -> (mkApp (Q c) xss : ps, j, g',k') 
+     PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
                    where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
     PImplArg p -> p2t p (ps,i,g,k)
     PTilde t -> (t : ps, i, g, k)
@@ -307,8 +308,8 @@ checkPatt th tenv exp val = do
       case typ of
         VClos env (Prod _ x a b) -> do
           (a',_,csa) <- checkExpP tenv t (VClos env a)
-	   b' <- whnf $ VClos ((x,VClos rho t):env) b
-	   return $ (AApp f' a' b', b', csf ++ csa)
+           b' <- whnf $ VClos ((x,VClos rho t):env) b
+           return $ (AApp f' a' b', b', csf ++ csa)
         _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
     _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))

@@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
 mkAnnot a ti = do
  (v,cs) <- ti
  return (a v, v, cs)
-
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.8 $
 --
@@ -27,20 +27,21 @@ import Data.List
 import qualified Data.Map as Map
 import Control.Monad
 import GF.Text.Pretty
+import qualified Control.Monad.Fail as Fail

 -- | combine a list of definitions into a balanced binary search tree
-buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (BinTree Ident Info)
+buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info)
 buildAnyTree m = go Map.empty
  where
    go map []         = return map
-    go map ((c,j):is) = do
+    go map ((c,j):is) =
      case Map.lookup c map of
        Just i  -> case unifyAnyInfo m i j of
-		     Ok k  -> go (Map.insert c k map) is
-		     Bad _ -> fail $ render ("conflicting information in module"<+>m $$
-		                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                             "and" $+$
-		                             nest 4 (ppJudgement Qualified (c,j)))
+          Ok k  -> go (Map.insert c k map) is
+          Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+                                  nest 4 (ppJudgement Qualified (c,i)) $$
+                                  "and" $+$
+                                  nest 4 (ppJudgement Qualified (c,j)))
        Nothing -> go (Map.insert c j map) is

 extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -50,14 +51,14 @@ extendModule cwd gr (name,m)
  ---- Should be replaced by real control. AR 4/2/2005
  | mstatus m == MSIncomplete && isModCnc m = return (name,m)
  | otherwise                               = checkInModule cwd m NoLoc empty $ do
-                                                 m' <- foldM extOne m (mextend m) 
+                                                 m' <- foldM extOne m (mextend m)
                                                 return (name,m')
 where
   extOne mo (n,cond) = do
     m0 <- lookupModule gr n

     -- test that the module types match, and find out if the old is complete
-     unless (sameMType (mtype m) (mtype mo)) 
+     unless (sameMType (mtype m) (mtype mo))
            (checkError ("illegal extension type to module" <+> name))

     let isCompl = isCompleteModule m0
@@ -66,7 +67,7 @@ extendModule cwd gr (name,m)
     js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)

     -- if incomplete, throw away extension information
-     return $ 
+     return $
          if isCompl
            then mo {jments = js1}
            else mo {mextend= filter ((/=n) . fst) (mextend mo)
@@ -74,7 +75,7 @@ extendModule cwd gr (name,m)
                    ,jments = js1
                    }

-- | rebuilding instance + interface, and "with" modules, prior to renaming. 
+-- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
 rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
@@ -87,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js

    -- add the information given in interface into an instance module
    Nothing -> do
-      unless (null is || mstatus mi == MSIncomplete) 
-             (checkError ("module" <+> i <+> 
+      unless (null is || mstatus mi == MSIncomplete)
+             (checkError ("module" <+> i <+>
                          "has open interfaces and must therefore be declared incomplete"))
      case mt of
        MTInstance (i0,mincl) -> do
@@ -101,17 +102,18 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
            []  -> return mi{jments=js'}
            j0s -> do
                m0s <- mapM (lookupModule gr) j0s
-                let notInM0 c _  = all (not . isInBinTree c . jments) m0s
-                let js2 = filterBinTree notInM0 js'
+                let notInM0 c _  = all (not . Map.member c . jments) m0s
+                let js2 = Map.filterWithKey notInM0 js'
                return mi{jments=js2}
        _ -> return mi

    -- add the instance opens to an incomplete module "with" instances
    Just (ext,incl,ops) -> do
      let (infs,insts) = unzip ops
-      let stat' = ifNull MSComplete (const MSIncomplete)
-                    [i | i <- is, notElem i infs]
-      unless (stat' == MSComplete || stat == MSIncomplete) 
+      let stat' = if all (flip elem infs) is
+                    then MSComplete
+                    else MSIncomplete
+      unless (stat' == MSComplete || stat == MSIncomplete)
             (checkError ("module" <+> i <+> "remains incomplete"))
      ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
      let ops1 = nub $
@@ -123,8 +125,11 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js

      --- check if me is incomplete
      let fs1 = fs `addOptions` fs_                           -- new flags have priority
-      let js0 = [(c,globalizeLoc fpath j) | (c,j) <- tree2list js, isInherited incl c]
-      let js1 = buildTree (tree2list js_ ++ js0)
+      let js0 = Map.mapMaybeWithKey (\c j -> if isInherited incl c
+                                               then Just (globalizeLoc fpath j)
+                                               else Nothing)
+                                    js
+      let js1 = Map.union js0 js_
      let med1= nub (ext : infs ++ insts ++ med_)
      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1

@@ -135,37 +140,37 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
 -- If the extended module is incomplete, its judgements are just copied.
 extendMod :: Grammar ->
             Bool -> (Module,Ident -> Bool) -> ModuleName ->
-             BinTree Ident Info -> Check (BinTree Ident Info)
-extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) 
+             Map.Map Ident Info -> Check (Map.Map Ident Info)
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
  where
    try new (c,i0)
      | not (cond c) = return new
      | otherwise    = case Map.lookup c new of
                         Just j -> case unifyAnyInfo name i j of
-		                     Ok k  -> return $ updateTree (c,k) new
-		                     Bad _ -> do (base,j) <- case j of 
-		                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
-		                                               _          -> return (base,j)
-		                                 (name,i) <- case i of 
+                                     Ok k  -> return $ Map.insert c k new
+                                     Bad _ -> do (base,j) <- case j of
+                                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
+                                                               _          -> return (base,j)
+                                                 (name,i) <- case i of
                                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
                                                               _          -> return (name,i)
-		                                 checkError ("cannot unify the information" $$ 
-		                                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                                             "in module" <+> name <+> "with" $$
-		                                             nest 4 (ppJudgement Qualified (c,j)) $$
-		                                             "in module" <+> base)
+                                                 checkError ("cannot unify the information" $$
+                                                             nest 4 (ppJudgement Qualified (c,i)) $$
+                                                             "in module" <+> name <+> "with" $$
+                                                             nest 4 (ppJudgement Qualified (c,j)) $$
+                                                             "in module" <+> base)
                         Nothing-> if isCompl
-                                     then return $ updateTree (c,indirInfo name i) new
-                                     else return $ updateTree (c,i) new
+                                     then return $ Map.insert c (indirInfo name i) new
+                                     else return $ Map.insert c i new
      where
        i = globalizeLoc (msrc mi) i0

    indirInfo :: ModuleName -> Info -> Info
-    indirInfo n info = AnyInd b n' where 
+    indirInfo n info = AnyInd b n' where
      (b,n') = case info of
        ResValue _ -> (True,n)
        ResParam _ _ -> (True,n)
-        AbsFun _ _ Nothing _ -> (True,n) 
+        AbsFun _ _ Nothing _ -> (True,n)
        AnyInd b k -> (b,k)
        _ -> (False,n) ---- canonical in Abs

@@ -189,24 +194,24 @@ globalizeLoc fpath i =

 unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
 unifyAnyInfo m i j = case (i,j) of
-  (AbsCat mc1, AbsCat mc2) -> 
+  (AbsCat mc1, AbsCat mc2) ->
    liftM AbsCat (unifyMaybeL mc1 mc2)
-  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> 
+  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
    liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs

  (ResParam mt1 mv1, ResParam mt2 mv2) ->
    liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
-  (ResValue (L l1 t1), ResValue (L l2 t2)) 
+  (ResValue (L l1 t1), ResValue (L l2 t2))
      | t1==t2    -> return (ResValue (L l1 t1))
      | otherwise -> fail ""
  (_, ResOverload ms t) | elem m ms ->
    return $ ResOverload ms t
-  (ResOper mt1 m1, ResOper mt2 m2) -> 
+  (ResOper mt1 m1, ResOper mt2 m2) ->
    liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)

-  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> 
+  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2)  (unifyMaybe mpmcfg1 mpmcfg2)
-  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> 
+  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
    liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)

  (AnyInd b1 m1, AnyInd b2 m2) -> do
--- a/src/compiler/GF/Compile/pgf.schema.json
+++ b/src/compiler/GF/Compile/pgf.schema.json
@@ -0,0 +1,232 @@
+{
+  "$schema": "http://json-schema.org/draft-07/schema#",
+  "$id": "http://grammaticalframework.org/pgf.schema.json",
+  "type": "object",
+  "title": "PGF JSON Schema",
+  "required": [
+    "abstract",
+    "concretes"
+  ],
+  "properties": {
+    "abstract": {
+      "type": "object",
+      "required": [
+        "name",
+        "startcat",
+        "funs"
+      ],
+      "properties": {
+        "name": {
+          "type": "string"
+        },
+        "startcat": {
+          "type": "string"
+        },
+        "funs": {
+          "type": "object",
+          "additionalProperties": {
+            "type": "object",
+            "required": [
+              "args",
+              "cat"
+            ],
+            "properties": {
+              "args": {
+                "type": "array",
+                "items": {
+                  "type": "string"
+                }
+              },
+              "cat": {
+                "type": "string"
+              }
+            }
+          }
+        }
+      }
+    },
+    "concretes": {
+      "type": "object",
+      "additionalProperties": {
+        "required": [
+          "flags",
+          "productions",
+          "functions",
+          "sequences",
+          "categories",
+          "totalfids"
+        ],
+        "properties": {
+          "flags": {
+            "type": "object",
+            "additionalProperties": {
+              "type": ["string", "number"]
+            }
+          },
+          "productions": {
+            "type": "object",
+            "additionalProperties": {
+              "type": "array",
+              "items": {
+                "oneOf": [
+                  {
+                    "$ref": "#/definitions/apply"
+                  },
+                  {
+                    "$ref": "#/definitions/coerce"
+                  }
+                ]
+              }
+            }
+          },
+          "functions": {
+            "type": "array",
+            "items": {
+              "title": "CncFun",
+              "type": "object",
+              "properties": {
+                "name": {
+                  "type": "string"
+                },
+                "lins": {
+                  "type": "array",
+                  "items": {
+                    "type": "integer"
+                  }
+                }
+              }
+            }
+          },
+          "sequences": {
+            "type": "array",
+            "items": {
+              "type": "array",
+              "items": {
+                "$ref": "#/definitions/sym"
+              }
+            }
+          },
+          "categories": {
+            "type": "object",
+            "additionalProperties": {
+              "title": "CncCat",
+              "type": "object",
+              "required": [
+                "start",
+                "end"
+              ],
+              "properties": {
+                "start": {
+                  "type": "integer"
+                },
+                "end": {
+                  "type": "integer"
+                }
+              }
+            }
+          },
+          "totalfids": {
+            "type": "integer"
+          }
+        }
+      }
+    }
+  },
+  "definitions": {
+    "apply": {
+      "required": [
+        "type",
+        "fid",
+        "args"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": ["Apply"]
+        },
+        "fid": {
+          "type": "integer"
+        },
+        "args": {
+          "type": "array",
+          "items": {
+            "$ref": "#/definitions/parg"
+          }
+        }
+      }
+    },
+    "coerce": {
+      "required": [
+        "type",
+        "arg"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": ["Coerce"]
+        },
+        "arg": {
+          "type": "integer"
+        }
+      }
+    },
+    "parg": {
+      "required": [
+        "type",
+        "hypos",
+        "fid"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": ["PArg"]
+        },
+        "hypos": {
+          "type": "array",
+          "items": {
+            "type": "integer"
+          }
+        },
+        "fid": {
+          "type": "integer"
+        }
+      }
+    },
+    "sym": {
+      "title": "Sym",
+      "required": [
+        "type",
+        "args"
+      ],
+      "properties": {
+        "type": {
+          "type": "string",
+          "enum": [
+            "SymCat",
+            "SymLit",
+            "SymVar",
+            "SymKS",
+            "SymKP",
+            "SymNE"
+          ]
+        },
+        "args": {
+          "type": "array",
+          "items": {
+            "anyOf": [
+              {
+                "type": "string"
+              },
+              {
+                "type": "integer"
+              },
+              {
+                "$ref": "#/definitions/sym"
+              }
+            ]
+          }
+        }
+      }
+    }
+  }
+}
--- a/src/compiler/GF/CompileInParallel.hs
+++ b/src/compiler/GF/CompileInParallel.hs
@@ -20,6 +20,8 @@ import GF.Infra.Ident(moduleNameS)
 import GF.Text.Pretty
 import GF.System.Console(TermColors(..),getTermColors)
 import qualified Data.ByteString.Lazy as BS
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail

 -- | Compile the given grammar files and everything they depend on,
 -- like 'batchCompile'. This function compiles modules in parallel.
@@ -83,7 +85,7 @@ batchCompile1 lib_dir (opts,filepaths) =
     let rel = relativeTo lib_dir cwd
         prelude_dir = lib_dir</>"prelude"
         gfoDir = flag optGFODir opts
-     maybe done (D.createDirectoryIfMissing True) gfoDir
+     maybe (return ()) (D.createDirectoryIfMissing True) gfoDir
 {-
     liftIO $ writeFile (maybe "" id gfoDir</>"paths")
                        (unlines . map (unwords . map rel) . nub $ map snd filepaths)
@@ -241,14 +243,14 @@ instance (Functor m,Monad m) => Applicative (CollectOutput m) where
  (<*>) = ap

 instance Monad m => Monad (CollectOutput m) where
-  return x = CO (return (done,x))
+  return x = CO (return (return (),x))
  CO m >>= f = CO $ do (o1,x) <- m
                       let CO m2 = f x
                       (o2,y) <- m2
                       return (o1>>o2,y)
 instance MonadIO m => MonadIO (CollectOutput m) where
  liftIO io = CO $ do x <- liftIO io
-                      return (done,x)
+                      return (return (),x)

 instance Output m => Output (CollectOutput m) where
  ePutStr   s = CO (return (ePutStr s,()))
@@ -256,6 +258,9 @@ instance Output m => Output (CollectOutput m) where
  putStrLnE s = CO (return (putStrLnE s,()))
  putStrE   s = CO (return (putStrE s,()))

+instance Fail.MonadFail m => Fail.MonadFail (CollectOutput m) where
+  fail = CO . fail
+
 instance ErrorMonad m => ErrorMonad (CollectOutput m) where
  raise e = CO (raise e)
  handle (CO m) h = CO $ handle m (unCO . h)
--- a/src/compiler/GF/CompileOne.hs
+++ b/src/compiler/GF/CompileOne.hs
@@ -21,7 +21,7 @@ import GF.Grammar.Binary(decodeModule,encodeModule)
 import GF.Infra.Option
 import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE)
 import GF.Infra.CheckM(runCheck')
-import GF.Data.Operations(ErrorMonad,liftErr,(+++),done)
+import GF.Data.Operations(ErrorMonad,liftErr,(+++))

 import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile)
 import System.FilePath(makeRelative)
@@ -30,12 +30,13 @@ import qualified Data.Map as Map
 import GF.Text.Pretty(render,(<+>),($$)) --Doc,
 import GF.System.Console(TermColors(..),getTermColors)
 import Control.Monad((<=<))
+import qualified Control.Monad.Fail as Fail

 type OneOutput = (Maybe FullPath,CompiledModule)
 type CompiledModule = Module

 compileOne, reuseGFO, useTheSource ::
-    (Output m,ErrorMonad m,MonadIO m) =>
+    (Output m,ErrorMonad m,MonadIO m, Fail.MonadFail m) =>
    Options -> Grammar -> FullPath -> m OneOutput

 -- | Compile a given source file (or just load a .gfo file),
@@ -66,7 +67,7 @@ reuseGFO opts srcgr file =

     if flag optTagsOnly opts
       then writeTags opts srcgr (gf2gftags opts file) sm1
-       else done
+       else return ()

     return (Just file,sm)

@@ -137,7 +138,7 @@ compileSourceModule opts cwd mb_gfFile gr =
           idump opts pass (dump out)
           return (ret out)

-    maybeM f = maybe done f
+    maybeM f = maybe (return ()) f


 --writeGFO :: Options -> InitPath -> FilePath -> SourceModule -> IOE ()
@@ -158,12 +159,12 @@ writeGFO opts cwd file mo =
 --intermOut :: Options -> Dump -> Doc -> IOE ()
 intermOut opts d doc
  | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
-  | otherwise   = done
+  | otherwise   = return ()

 idump opts pass = intermOut opts (Dump pass) . ppModule Internal

 warnOut opts warnings
-  | null warnings = done
+  | null warnings = return ()
  | otherwise     = do t <- getTermColors
                       ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
  where
--- a/src/compiler/GF/Compiler.hs
+++ b/src/compiler/GF/Compiler.hs
@@ -7,6 +7,7 @@ import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
 import GF.Compile.ConcreteToHaskell(concretes2haskell)
+import GF.Compile.GrammarToCanonical--(concretes2canonical)
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
@@ -17,12 +18,13 @@ import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.Data.ErrM
 import GF.System.Directory
-import GF.Text.Pretty(render)
+import GF.Text.Pretty(render,render80)

 import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.ByteString.Lazy as BSL
+import GF.Grammar.CanonicalJSON (encodeJSON)
 import System.FilePath
 import Control.Monad(when,unless,forM_)

@@ -47,7 +49,7 @@ mainGFC opts fs = do
 compileSourceFiles :: Options -> [FilePath] -> IOE ()
 compileSourceFiles opts fs = 
    do output <- batchCompile opts fs
-       cncs2haskell output
+       exportCanonical output
       unless (flag optStopAfterPhase opts == Compile) $
           linkGrammars opts output
  where
@@ -55,15 +57,35 @@ compileSourceFiles opts fs =
    batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
                               return (t,[cnc_gr])

-    cncs2haskell output =
-      when (FmtHaskell `elem` flag optOutputFormats opts &&
-            haskellOption opts HaskellConcrete) $
-        mapM_ cnc2haskell (snd output)
+    exportCanonical (_time, canonical) =
+      do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
+           mapM_ cnc2haskell canonical
+         when (FmtCanonicalGF `elem` ofmts) $
+           do createDirectoryIfMissing False "canonical"
+              mapM_ abs2canonical canonical
+              mapM_ cnc2canonical canonical
+         when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
+      where
+        ofmts = flag optOutputFormats opts

    cnc2haskell (cnc,gr) =
-        mapM_ writeHs $ concretes2haskell opts (srcAbsName gr cnc) gr
+      do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr

-    writeHs (path,s) = writing opts path $ writeUTF8File path s
+    abs2canonical (cnc,gr) =
+        writeExport ("canonical/"++render absname++".gf",render80 canAbs)
+      where
+        absname = srcAbsName gr cnc
+        canAbs = abstract2canonical absname gr
+
+    cnc2canonical (cnc,gr) =
+      mapM_ (writeExport.fmap render80) $
+            concretes2canonical opts (srcAbsName gr cnc) gr
+
+    grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon
+      where absname = srcAbsName gr cnc
+            gr_canon = grammar2canonical opts absname gr
+
+    writeExport (path,s) = writing opts path $ writeUTF8File path s


 -- | Create a @.pgf@ file (and possibly files in other formats, if specified
@@ -80,7 +102,9 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
       if t_pgf >= Just t_src
         then putIfVerb opts $ pgfFile ++ " is up-to-date."
         else do pgfs <- mapM (link opts) cnc_grs
-                 let pgf = foldl1 unionPGF pgfs
+                 let pgf0 = foldl1 unionPGF pgfs
+                 probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf0
+                 let pgf = setProbabilities probs pgf0
                 writePGF opts pgf
                 writeOutputs opts pgf

@@ -115,7 +139,9 @@ unionPGFFiles opts fs =
    doIt =
      do pgfs <- mapM readPGFVerbose fs
         let pgf0 = foldl1 unionPGF pgfs
-             pgf  = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
+             pgf1 = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
+         probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf1)
+         let pgf  = setProbabilities probs pgf1
             pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
         if pgfFile `elem` fs
           then putStrLnE $ "Refusing to overwrite " ++ pgfFile
--- a/src/compiler/GF/CompilerAPI.hs
+++ b/src/compiler/GF/CompilerAPI.hs
@@ -16,8 +16,6 @@ import GF.Compile.ReadFiles
 import GF.Compile.Update
 import GF.Compile.Refresh

-import GF.Compile.Coding
-
 import GF.Grammar.Grammar
 import GF.Grammar.Lookup
 import GF.Grammar.Printer
--- a/src/compiler/GF/Data/BacktrackM.hs
+++ b/src/compiler/GF/Data/BacktrackM.hs
@@ -13,25 +13,27 @@
 -----------------------------------------------------------------------------

 {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
 module GF.Data.BacktrackM (
                    -- * the backtracking state monad
-		    BacktrackM,
-		    -- * monad specific utilities
-		    member,
-		    cut,
-		    -- * running the monad
-		    foldBM,          runBM,
-		    foldSolutions,   solutions,
-		    foldFinalStates, finalStates,
-		    
-		    -- * reexport the 'MonadState' class
-		    module Control.Monad.State.Class,
-		  ) where
+                    BacktrackM,
+                    -- * monad specific utilities
+                    member,
+                    cut,
+                    -- * running the monad
+                    foldBM,          runBM,
+                    foldSolutions,   solutions,
+                    foldFinalStates, finalStates,
+
+                    -- * reexport the 'MonadState' class
+                    module Control.Monad.State.Class,
+                  ) where

 import Data.List
 import Control.Applicative
 import Control.Monad
 import Control.Monad.State.Class
+import qualified Control.Monad.Fail as Fail

 ----------------------------------------------------------------------
 -- Combining endomorphisms and continuations
@@ -68,7 +70,13 @@ 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
+#endif
+
+instance Fail.MonadFail (BacktrackM s) where
    fail _ = mzero

 instance Functor (BacktrackM s) where
--- a/src/compiler/GF/Data/ErrM.hs
+++ b/src/compiler/GF/Data/ErrM.hs
@@ -12,10 +12,12 @@
 -- hack for BNFC generated files. AR 21/9/2003
 -----------------------------------------------------------------------------

+{-# LANGUAGE CPP #-}
 module GF.Data.ErrM where

 import Control.Monad (MonadPlus(..),ap)
 import Control.Applicative
+import qualified Control.Monad.Fail as Fail

 -- | Like 'Maybe' type with error msgs
 data Err a = Ok a | Bad String
@@ -33,10 +35,19 @@ fromErr a = err (const a) id

 instance Monad Err where
  return      = Ok
-  fail        = Bad
  Ok a  >>= f = f a
  Bad s >>= f = Bad s

+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail Err where
+  fail        = Bad
+
+
+
 -- | added 2\/10\/2003 by PEB
 instance Functor Err where
  fmap f (Ok a) = Ok (f a)
--- a/src/compiler/GF/Data/Graph.hs
+++ b/src/compiler/GF/Data/Graph.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/11/10 16:43:44 $ 
+-- > CVS $Date: 2005/11/10 16:43:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.2 $
 --
@@ -34,7 +34,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set

 data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
-		 deriving (Eq,Show)
+    deriving (Eq,Show)

 type Node n a = (n,a)
 type Edge n b = (n,n,b)
@@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]

 -- | Add a node to the graph.
 newNode :: a               -- ^ Node label
-        -> Graph n a b 
+        -> Graph n a b
        -> (Graph n a b,n) -- ^ Node graph and name of new node
 newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)

@@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es
 -- lazy version:
 -- newEdges es' (Graph c ns es) = Graph c ns (es'++es)

-insertEdgeWith :: Eq n => 
+insertEdgeWith :: Eq n =>
                  (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
 insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
  where h [] = [e]
@@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n)
 -- | Remove a set of nodes and all edges to and from those nodes.
 removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
 removeNodes xs (Graph c ns es) = Graph c ns' es'
-  where 
+  where
  keepNode n = not (Set.member n xs)
  ns' = [ x | x@(n,_) <- ns, keepNode n ]
  es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
@@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es'
 -- | Get a map of node names to info about each node.
 nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
 nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
-  where 
+  where
  inc = groupEdgesBy edgeTo g
  out = groupEdgesBy edgeFrom g
  fn m n = fromMaybe [] (Map.lookup n m)
@@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b
 reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]

 -- | Add the nodes from the second graph to the first graph.
--   The nodes in the second graph will be renamed using the name 
+--   The nodes in the second graph will be renamed using the name
 --   supply in the first graph.
 --   This function is more efficient when the second graph
 --   is smaller than the first.
-mergeGraphs :: Ord m => Graph n a b -> Graph m a b 
+mergeGraphs :: Ord m => Graph n a b -> Graph m a b
            -> (Graph n a b, m -> n) -- ^ The new graph and a function translating
                                      --  the old names of nodes in the second graph
                                      --  to names in the new graph.
 mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
-  where 
+  where
  (xs,c') = splitAt (length (nodes g2)) c
  newNames = Map.fromList (zip (map fst (nodes g2)) xs)
  newName n = fromJust $ Map.lookup n newNames
@@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function
            -> Graph n a b -> Graph m a b
 renameNodes newName c (Graph _ ns es) = Graph c ns' es'
    where ns' = map' (\ (n,x) -> (newName n,x)) ns
-	  es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
+          es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es

 -- | A strict 'map'
 map' :: (a -> b) -> [a] -> [b]
--- a/src/compiler/GF/Data/Graphviz.hs
+++ b/src/compiler/GF/Data/Graphviz.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/09/15 18:10:44 $ 
+-- > CVS $Date: 2005/09/15 18:10:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.2 $
 --
@@ -13,14 +13,14 @@
 -----------------------------------------------------------------------------

 module GF.Data.Graphviz (
-				  Graph(..), GraphType(..), 
-				  Node(..), Edge(..),
-				  Attr,
-                                  addSubGraphs,
-                                  setName,
-                                  setAttr,
-				  prGraphviz
-			) where
+                          Graph(..), GraphType(..),
+                          Node(..), Edge(..),
+                          Attr,
+                          addSubGraphs,
+                          setName,
+                          setAttr,
+                          prGraphviz
+                        ) where

 import Data.Char

@@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) =
    graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"

 prSubGraph :: Graph -> String
-prSubGraph g@(Graph _ i _ _ _ _) = 
+prSubGraph g@(Graph _ i _ _ _ _) =
    "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"

 prGraph :: Graph -> String
-prGraph (Graph t id at ns es ss) = 
+prGraph (Graph t id at ns es ss) =
    unlines $ map (++";") (map prAttr at
-		           ++ map prNode ns 
-		           ++ map (prEdge t) es
+                           ++ map prNode ns
+                           ++ map (prEdge t) es
                           ++ map prSubGraph ss)

 graphtype :: GraphType -> String
@@ -96,7 +96,7 @@ edgeop Undirected = "--"

 prAttrList :: [Attr] -> String
 prAttrList [] = ""
-prAttrList at =	"[" ++ join "," (map prAttr at) ++ "]"
+prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"

 prAttr :: Attr -> String
 prAttr (n,v) = esc n ++ " = " ++ esc v
--- a/src/compiler/GF/Data/Operations.hs
+++ b/src/compiler/GF/Data/Operations.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/11/11 16:12:41 $ 
+-- > CVS $Date: 2005/11/11 16:12:41 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.22 $
 --
@@ -15,47 +15,34 @@
 -----------------------------------------------------------------------------

 module GF.Data.Operations (
-		   -- ** The Error monad
-		   Err(..), err, maybeErr, testErr, fromErr, errIn, 
-		   lookupErr,
+     -- ** The Error monad
+     Err(..), err, maybeErr, testErr, fromErr, errIn,
+     lookupErr,

-		   -- ** Error monad class
-		   ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
-                   liftErr,
-		   
-		   -- ** Checking
-		   checkUnique, unifyMaybeBy, unifyMaybe,
+     -- ** Error monad class
+     ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
+                 liftErr,

-                   -- ** Monadic operations on lists and pairs
-		   mapPairListM, mapPairsM, pairM,
+     -- ** Checking
+     checkUnique, unifyMaybeBy, unifyMaybe,

-		   -- ** Binary search trees; now with FiniteMap
-		   BinTree, emptyBinTree, isInBinTree, --justLookupTree,
-		   lookupTree, --lookupTreeMany,
-                   lookupTreeManyAll, updateTree,
-		   buildTree, filterBinTree,
-                   mapTree, --mapMTree,
-                   tree2list,
- 
-		   -- ** Printing
-		   indent, (+++), (++-), (++++), (+++-), (+++++),
-		   prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, 
-		   prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
-		   numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+         -- ** Monadic operations on lists and pairs
+     mapPairsM, pairM,

-		   -- ** Topological sorting
-		   topoTest, topoTest2,
+     -- ** Printing
+     indent, (+++), (++-), (++++), (+++-), (+++++),
+     prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
+     prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+     numberedParagraphs, prConjList, prIfEmpty, wrapLines,

-		   -- ** Misc
-		   ifNull,
-		   combinations, done, readIntArg, --singleton,
-		   iterFix,  chunks,
-{-
-		   -- ** State monad with error; from Agda 6\/11\/2001
-		   STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
-}
-                
-		  ) where
+     -- ** Topological sorting
+     topoTest, topoTest2,
+
+     -- ** Misc
+     readIntArg,
+     iterFix,  chunks,
+
+    ) where

 import Data.Char (isSpace, toUpper, isSpace, isDigit)
 import Data.List (nub, partition, (\\))
@@ -66,15 +53,13 @@ import Control.Monad (liftM,liftM2) --,ap

 import GF.Data.ErrM
 import GF.Data.Relation
+import qualified Control.Monad.Fail as Fail

 infixr 5 +++
 infixr 5 ++-
 infixr 5 ++++
 infixr 5 +++++

-ifNull :: b -> ([a] -> b) -> [a] -> b
-ifNull b f xs = if null xs then b else f xs
-
 -- the Error monad

 -- | Add msg s to 'Maybe' failures
@@ -82,7 +67,7 @@ maybeErr :: ErrorMonad m => String -> Maybe a -> m a
 maybeErr s = maybe (raise s) return

 testErr :: ErrorMonad m => Bool -> String -> m ()
-testErr cond msg = if cond then done else raise msg
+testErr cond msg = if cond then return () else raise msg

 errIn :: ErrorMonad m => String -> m a -> m a
 errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
@@ -90,9 +75,6 @@ errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
 lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
 lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)

-mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
-mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys
-
 mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
 mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys

@@ -107,54 +89,16 @@ checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
  overloaded s = length (filter (==s) ss) > 1

 -- | this is what happens when matching two values in the same module
-unifyMaybe :: (Eq a, Monad m) => Maybe a -> Maybe a -> m (Maybe a)
+unifyMaybe :: (Eq a, Fail.MonadFail m) => Maybe a -> Maybe a -> m (Maybe a)
 unifyMaybe = unifyMaybeBy id

-unifyMaybeBy :: (Eq b, Monad m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
+unifyMaybeBy :: (Eq b, Fail.MonadFail m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
 unifyMaybeBy f (Just p1) (Just p2)
  | f p1==f p2                     = return (Just p1)
  | otherwise                      = fail ""
 unifyMaybeBy _ Nothing   mp2       = return mp2
 unifyMaybeBy _ mp1       _         = return mp1

-- binary search trees
-
-type BinTree a b = Map a b
-
-emptyBinTree :: BinTree a b
-emptyBinTree = Map.empty
-
-isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
-isInBinTree = Map.member
-{-
-justLookupTree :: (ErrorMonad m,Ord a) => a -> BinTree a b -> m b
-justLookupTree = lookupTree (const [])
-}
-lookupTree :: (ErrorMonad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
-lookupTree pr x = maybeErr no . Map.lookup x
-  where no = "no occurrence of element" +++ pr x
-
-lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b]
-lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of
-  Ok v -> v : lookupTreeManyAll pr ts x
-  _ -> lookupTreeManyAll pr ts x
-lookupTreeManyAll pr [] x = []
-
-updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
-updateTree (a,b) = Map.insert a b
-
-buildTree :: (Ord a) => [(a,b)] -> BinTree a b
-buildTree = Map.fromList
-
-mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
-mapTree f = Map.mapWithKey (\k v -> f (k,v))
-
-filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
-filterBinTree = Map.filterWithKey
-
-tree2list :: BinTree a b -> [(a,b)] -- inorder
-tree2list = Map.toList
-
 -- printing

 indent :: Int -> String -> String
@@ -163,7 +107,7 @@ indent i s = replicate i ' ' ++ s
 (+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
 a +++ b   = a ++ " "    ++ b

-a ++- ""  = a 
+a ++- ""  = a
 a ++- b   = a +++ b

 a ++++ b  = a ++ "\n"   ++ b
@@ -201,20 +145,20 @@ prCurly   s = "{" ++ s ++ "}"
 prBracket s = "[" ++ s ++ "]"

 prArgList, prSemicList, prCurlyList :: [String] -> String
-prArgList   = prParenth . prTList "," 
+prArgList   = prParenth . prTList ","
 prSemicList = prTList " ; "
 prCurlyList = prCurly . prSemicList

 restoreEscapes :: String -> String
-restoreEscapes s = 
-  case s of 
+restoreEscapes s =
+  case s of
    []       -> []
    '"' : t  -> '\\' : '"'  : restoreEscapes t
    '\\': t  -> '\\' : '\\' : restoreEscapes t
    c   : t  -> c : restoreEscapes t

 numberedParagraphs :: [[String]] -> [String]
-numberedParagraphs t = case t of 
+numberedParagraphs t = case t of
  []   -> []
  p:[] -> p
  _    -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
@@ -243,21 +187,6 @@ wrapLines n s@(c:cs) =
                     l = length w
            _ -> s -- give up!!

--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
-
-- | 'combinations' is the same as 'sequence'!!!
-- peb 30\/5-04
-combinations :: [[a]] -> [[a]]
-combinations t = case t of 
-  []    -> [[]]
-  aa:uu -> [a:u | a <- aa, u <- combinations uu]
-
-{-
-- | 'singleton' is the same as 'return'!!!
-singleton :: a -> [a]
-singleton = (:[])
-}
-
 -- | Topological sorting with test of cyclicity
 topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
 topoTest = topologicalSort . mkRel'
@@ -275,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
        ([],[]) -> Just []
        ([],_) -> Nothing
        (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
-	  where leaves = map fst ns
+            where leaves = map fst ns


 -- | Fix point iterator (for computing e.g. transitive closures or reachability)
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
-iterFix more start = iter start start 
+iterFix more start = iter start start
  where
    iter old new = if (null new')
                      then old
@@ -297,46 +226,6 @@ chunks sep ws = case span (/= sep) ws of
 readIntArg :: String -> Int
 readIntArg n = if (not (null n) && all isDigit n) then read n else 0

-{-
-- state monad with error; from Agda 6/11/2001
-
-newtype STM s a = STM (s -> Err (a,s)) 
-
-appSTM :: STM s a -> s -> Err (a,s)
-appSTM (STM f) s = f s
-
-stm :: (s -> Err (a,s)) -> STM s a
-stm = STM
-
-stmr :: (s -> (a,s)) -> STM s a
-stmr f = stm (\s -> return (f s))
-
-instance Functor (STM s) where fmap = liftM
-
-instance Applicative (STM s) where
-  pure = return
-  (<*>) = ap
-
-instance  Monad (STM s) where
-  return a    = STM (\s -> return (a,s))
-  STM c >>= f = STM (\s -> do 
-                        (x,s') <- c s
-                        let STM f' = f x
-                        f' s')
-
-readSTM :: STM s s
-readSTM = stmr (\s -> (s,s))
-
-updateSTM :: (s -> s) -> STM s () 
-updateSTM f = stmr (\s -> ((),f s))
-
-writeSTM :: s -> STM s ()
-writeSTM s = stmr (const ((),s))
-}
-- | @return ()@
-done :: Monad m => m ()
-done = return ()
-
 class (Functor m,Monad m) => ErrorMonad m where
  raise   :: String -> m a
  handle  :: m a -> (String -> m a) -> m a
@@ -352,7 +241,7 @@ liftErr e = err raise return e
 {-
 instance ErrorMonad (STM s) where
  raise msg = STM (\s -> raise msg)
-  handle (STM f) g = STM (\s -> (f s) 
+  handle (STM f) g = STM (\s -> (f s)
                                `handle` (\e -> let STM g' = (g e) in
                                                    g' s))

@@ -377,4 +266,4 @@ doUntil cond ms = case ms of
    v <- a
    if cond v then return v else doUntil cond as
  _ -> raise "no result"
-}
+-}
--- a/src/compiler/GF/Data/Relation.hs
+++ b/src/compiler/GF/Data/Relation.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/10/26 17:13:13 $ 
+-- > CVS $Date: 2005/10/26 17:13:13 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.1 $
 --
@@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r
  where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)

 reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
-		 -> Rel a -> Rel a
+                  -> Rel a -> Rel a
 reflexiveClosure_ u r = relates [(x,x) | x <- u] r

 -- | Uses 'domain'
@@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a
 reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]

 -- | Keep the related pairs for which the predicate is true.
-filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a 
+filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
 filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)

 -- | Remove keys that map to no elements.
@@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
 purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
                in (r', Map.keysSet r'')

-- | Get the equivalence classes from an equivalence relation. 
+-- | Get the equivalence classes from an equivalence relation.
 equivalenceClasses :: Ord a => Rel a -> [Set a]
 equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
 where equivalenceClasses_ [] _ = []
       equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
-	   where ys = allRelated r x
-                 zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+          where ys = allRelated r x
+                zs = [x' | x' <- xs, not (x' `Set.member` ys)]

 isTransitive :: Ord a => Rel a -> Bool
-isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, 
+isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
                      y <- Set.toList ys, z <- Set.toList (allRelated r y)]

 isReflexive :: Ord a => Rel a -> Bool
@@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
                   Nothing      -> (r', Set.empty, Set.empty)
                   -- remove element from all incoming and outgoing sets
                   -- of other elements
-                   Just (is,os) -> 
+                   Just (is,os) ->
                       let r''  = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r'  $ Set.toList is
                           r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
                        in (r''', is, os)
@@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a
 incoming x r = maybe Set.empty fst $ Map.lookup x r

 --outgoing :: Ord a => a -> Rel' a -> Set a
--outgoing x r = maybe Set.empty snd $ Map.lookup x r
+--outgoing x r = maybe Set.empty snd $ Map.lookup x r
--- a/src/compiler/GF/Data/Utilities.hs
+++ b/src/compiler/GF/Data/Utilities.hs
@@ -4,7 +4,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/10/26 18:47:16 $ 
+-- > CVS $Date: 2005/10/26 18:47:16 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.6 $
 --
@@ -33,7 +33,7 @@ longerThan    n = not . notLongerThan n
 lookupList :: Eq a => a -> [(a, b)] -> [b]
 lookupList a [] = []
 lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
-		    | otherwise  =         lookupList a ps
+                    | otherwise  =         lookupList a ps

 split :: [a] -> ([a], [a])
 split (x : y : as) = (x:xs, y:ys)
@@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
 foldMerge :: (a -> a -> a) -> a -> [a] -> a
 foldMerge merge zero = fm
    where fm [] = zero
-	  fm [a] = a
-	  fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+          fm [a] = a
+          fm abs = let (as, bs) = split abs in fm as `merge` fm bs

 select :: [a] -> [(a, [a])]
 select [] = []
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
 safeInit [] = []
 safeInit xs = init xs

-- | Sorts and then groups elements given an ordering of the 
+-- | Sorts and then groups elements given an ordering of the
 --   elements.
 sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
 sortGroupBy f = groupBy (compareEq f) . sortBy f
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -0,0 +1,313 @@
+-- |
+-- Module    :  GF.Grammar.Canonical
+-- Stability :  provisional
+--
+-- Abstract syntax for canonical GF grammars, i.e. what's left after
+-- high-level constructions such as functors and opers have been eliminated
+-- by partial evaluation. This is intended as a common intermediate
+-- representation to simplify export to other formats.
+
+{-# LANGUAGE DeriveTraversable #-}
+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
+
+--------------------------------------------------------------------------------
+-- ** Abstract Syntax
+
+-- | Abstract Syntax
+data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
+abstrName (Abstract mn _ _ _) = mn
+
+data CatDef   = CatDef CatId [CatId]        deriving Show
+data FunDef   = FunDef FunId Type           deriving Show
+data Type     = Type [TypeBinding] TypeApp  deriving Show
+data TypeApp  = TypeApp CatId [Type]        deriving Show
+
+data TypeBinding = TypeBinding VarId Type   deriving Show
+
+--------------------------------------------------------------------------------
+-- ** Concreate syntax
+
+-- | Concrete Syntax
+data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
+                 deriving Show
+concName (Concrete cnc _ _ _ _ _) = cnc
+
+data ParamDef  = ParamDef ParamId [ParamValueDef]
+               | ParamAliasDef ParamId LinType
+               deriving Show
+data LincatDef = LincatDef CatId LinType  deriving Show
+data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
+
+-- | Linearization type, RHS of @lincat@
+data LinType = FloatType
+             | IntType
+             | ParamType ParamType
+             | RecordType [RecordRowType]
+             | StrType
+             | TableType LinType LinType
+             | TupleType [LinType]
+              deriving (Eq,Ord,Show)
+
+newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
+
+-- | Linearization value, RHS of @lin@
+data LinValue = ConcatValue LinValue LinValue
+              | LiteralValue LinLiteral
+              | ErrorValue String
+              | ParamConstant ParamValue
+              | PredefValue PredefId
+              | RecordValue [RecordRowValue]
+              | TableValue LinType [TableRowValue]
+---           | VTableValue LinType [LinValue]
+              | TupleValue [LinValue]
+              | VariantValue [LinValue]
+              | VarValue VarValueId
+              | PreValue [([String], LinValue)] LinValue
+              | Projection LinValue LabelId
+              | Selection LinValue LinValue
+              | CommentedValue String LinValue
+              deriving (Eq,Ord,Show)
+
+data LinLiteral = FloatConstant Float
+                | IntConstant Int
+                | StrConstant String
+                deriving (Eq,Ord,Show)
+
+data LinPattern = ParamPattern ParamPattern
+                | RecordPattern [RecordRow LinPattern]
+                | TuplePattern [LinPattern]
+                | WildPattern
+                deriving (Eq,Ord,Show)
+
+type ParamValue = Param LinValue
+type ParamPattern = Param LinPattern
+type ParamValueDef = Param ParamId
+
+data Param arg = Param ParamId [arg]
+                 deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+
+type RecordRowType  = RecordRow LinType
+type RecordRowValue = RecordRow LinValue
+type TableRowValue  = TableRow LinValue
+
+data RecordRow rhs = RecordRow LabelId    rhs
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+data TableRow  rhs = TableRow  LinPattern rhs
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+
+-- *** Identifiers in Concrete Syntax
+
+newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
+newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
+data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
+
+-- | Name of param type or param value
+newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
+
+--------------------------------------------------------------------------------
+-- ** Used in both Abstract and Concrete Syntax
+
+newtype ModId = ModId Id  deriving (Eq,Ord,Show)
+
+newtype CatId = CatId Id  deriving (Eq,Ord,Show)
+newtype FunId = FunId Id  deriving (Eq,Show)
+
+data VarId = Anonymous | VarId Id  deriving Show
+
+newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
+type FlagName = Id
+data FlagValue = Str String | Int Int | Flt Double deriving Show
+
+
+-- *** Identifiers
+
+type Id = RawIdent
+data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
+
+--------------------------------------------------------------------------------
+-- ** Pretty printing
+
+instance Pretty Grammar where
+  pp (Grammar abs cncs) = abs $+$ vcat cncs
+
+instance Pretty Abstract where
+  pp (Abstract m flags cats funs) =
+    "abstract" <+> m <+> "=" <+> "{" $$
+       flags $$
+       "cat" <+> fsep cats $$
+       "fun" <+> vcat funs $$
+       "}"
+
+instance Pretty CatDef where
+  pp (CatDef c cs) = hsep (c:cs)<>";"
+
+instance Pretty FunDef where
+  pp (FunDef f ty) = f <+> ":" <+> ty <>";"
+
+instance Pretty Type where
+  pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
+
+instance PPA Type where
+  ppA (Type [] (TypeApp c [])) = pp c
+  ppA t = parens t
+
+instance Pretty TypeBinding where
+  pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
+  pp (TypeBinding Anonymous ty) = parens ty
+  pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
+
+instance Pretty TypeApp where
+ pp (TypeApp c targs) = c<+>hsep (map ppA targs)
+
+instance Pretty VarId where
+  pp Anonymous = pp "_"
+  pp (VarId x) = pp x
+
+--------------------------------------------------------------------------------
+
+instance Pretty Concrete where
+  pp (Concrete cncid absid flags params lincats lins) =
+      "concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
+      vcat params $$
+      section "lincat" lincats $$
+      section "lin" lins $$
+      "}"
+    where
+      section name [] = empty
+      section name ds = name <+> vcat (map (<> ";") ds)
+
+instance Pretty ParamDef where
+  pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
+  pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
+
+instance PPA arg => Pretty (Param arg) where
+  pp (Param p ps) = pp p<+>sep (map ppA ps)
+
+instance PPA arg => PPA (Param arg) where
+  ppA (Param p []) = pp p
+  ppA pv = parens pv
+
+instance Pretty LincatDef where
+  pp (LincatDef c lt) = hang (c <+> "=") 4 lt
+
+instance Pretty LinType where
+ pp lt = case lt of
+           FloatType -> pp "Float"
+           IntType -> pp "Int"
+           ParamType pt -> pp pt
+           RecordType rs -> block rs
+           StrType -> pp "Str"
+           TableType pt lt -> sep [pt <+> "=>",pp lt]
+           TupleType lts -> "<"<>punctuate "," lts<>">"
+
+instance RhsSeparator LinType  where rhsSep _ = pp ":"
+
+instance Pretty ParamType where
+  pp (ParamTypeId p) = pp p
+
+instance Pretty LinDef where
+  pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
+
+instance Pretty LinValue where
+  pp lv = case lv of
+            ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
+            ErrorValue s -> "Predef.error"<+>doubleQuotes s
+            ParamConstant pv -> pp pv
+            Projection lv l -> ppA lv<>"."<>l
+            Selection tv pv -> ppA tv<>"!"<>ppA pv
+            VariantValue vs -> "variants"<+>block vs
+            CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
+            _ -> ppA lv
+
+instance PPA LinValue where
+  ppA lv = case lv of
+             LiteralValue l -> ppA l
+             ParamConstant pv -> ppA pv
+             PredefValue p -> ppA p
+             RecordValue [] -> pp "<>"
+             RecordValue rvs -> block rvs
+             PreValue alts def ->
+               "pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
+               where
+                 alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
+                                    2 ("=>"<+>lv)
+             TableValue _ tvs -> "table"<+>block tvs
+--           VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts)
+             TupleValue lvs -> "<"<>punctuate "," lvs<>">"
+             VarValue v -> pp v
+             _ -> parens lv
+
+instance Pretty LinLiteral where pp = ppA
+
+instance PPA LinLiteral where
+  ppA l = case l of
+            FloatConstant f -> pp f
+            IntConstant n -> pp n
+            StrConstant s -> doubleQuotes s -- hmm
+
+instance RhsSeparator LinValue where rhsSep _ = pp "="
+
+instance Pretty LinPattern where
+  pp p =
+    case p of
+      ParamPattern pv -> pp pv
+      _ -> ppA p
+
+instance PPA LinPattern where
+  ppA p =
+    case p of
+      ParamPattern pv -> ppA pv
+      RecordPattern r -> block r
+      TuplePattern ps -> "<"<>punctuate "," ps<>">"
+      WildPattern     -> pp "_"
+
+instance RhsSeparator LinPattern where rhsSep _ = pp "="
+
+instance RhsSeparator rhs => Pretty (RecordRow rhs) where
+  pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
+
+instance Pretty rhs => Pretty (TableRow rhs) where
+  pp (TableRow l v) = hang (l<+>"=>") 2 v
+
+--------------------------------------------------------------------------------
+instance Pretty ModId where pp (ModId s) = pp s
+instance Pretty CatId where pp (CatId s) = pp s
+instance Pretty FunId where pp (FunId s) = pp s
+instance Pretty LabelId where pp (LabelId s) = pp s
+instance Pretty PredefId where pp = ppA
+instance PPA    PredefId where ppA (PredefId s) = "Predef."<>s
+instance Pretty ParamId where pp = ppA
+instance PPA    ParamId where ppA (ParamId s) = pp s
+instance Pretty VarValueId where pp (VarValueId s) = pp s
+
+instance Pretty QualId where pp = ppA
+
+instance PPA QualId where
+  ppA (Qual m n) = m<>"_"<>n -- hmm
+  ppA (Unqual n) = pp n
+
+instance Pretty Flags where
+  pp (Flags []) = empty
+  pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)
+    where
+      ppFlag (name,value) = name <+> "=" <+> value <>";"
+
+instance Pretty FlagValue where
+  pp (Str s) = pp s
+  pp (Int i) = pp i
+  pp (Flt d) = pp d
+
+--------------------------------------------------------------------------------
+-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
+class Pretty a => PPA a where ppA :: a -> Doc
+
+class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
+
+semiSep xs = punctuate ";" xs
+block xs = braces (semiSep xs)
--- a/src/compiler/GF/Grammar/CanonicalJSON.hs
+++ b/src/compiler/GF/Grammar/CanonicalJSON.hs
@@ -0,0 +1,298 @@
+module GF.Grammar.CanonicalJSON (
+  encodeJSON
+  ) where
+
+import Text.JSON
+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 ()
+encodeJSON fpath g = writeFile fpath (encode g)
+
+
+-- in general we encode grammars using JSON objects/records,
+-- except for newtypes/coercions/direct values
+
+-- the top-level definitions use normal record labels,
+-- but recursive types/values/ids use labels staring with a "."
+
+instance JSON Grammar where
+  showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
+
+  readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
+
+
+--------------------------------------------------------------------------------
+-- ** Abstract Syntax
+
+instance JSON Abstract where
+  showJSON (Abstract absid flags cats funs)
+    = makeObj [("abs", showJSON absid),
+               ("flags", showJSON flags),
+               ("cats", showJSON cats),
+               ("funs", showJSON funs)]
+
+  readJSON o = Abstract
+    <$> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"cats"
+    <*> o!"funs"
+
+instance JSON CatDef where
+  -- non-dependent categories are encoded as simple strings:
+  showJSON (CatDef c []) = showJSON c
+  showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
+
+  readJSON o = CatDef <$> readJSON o <*> return []
+    <|>        CatDef <$> o!"cat" <*> o!"args"
+
+instance JSON FunDef where
+  showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
+
+  readJSON o = FunDef <$> o!"fun" <*> o!"type"
+
+instance JSON Type where
+  showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
+
+  readJSON o = Type <$> o!".args" <*> o!".result"
+
+instance JSON TypeApp where
+  -- non-dependent categories are encoded as simple strings:
+  showJSON (TypeApp c [])   = showJSON c
+  showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
+
+  readJSON o = TypeApp <$> readJSON o <*> return []
+    <|>        TypeApp <$> o!".cat" <*> o!".args"
+
+instance JSON TypeBinding where
+  -- non-dependent categories are encoded as simple strings:
+  showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
+  showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
+
+  readJSON o = do c <- readJSON o
+                  return (TypeBinding Anonymous (Type [] (TypeApp c [])))
+           <|> TypeBinding <$> o!".var" <*> o!".type"
+
+
+--------------------------------------------------------------------------------
+-- ** Concrete syntax
+
+instance JSON Concrete where
+  showJSON (Concrete cncid absid flags params lincats lins)
+    = makeObj [("cnc", showJSON cncid),
+               ("abs", showJSON absid),
+               ("flags", showJSON flags),
+               ("params", showJSON params),
+               ("lincats", showJSON lincats),
+               ("lins", showJSON lins)]
+
+  readJSON o = Concrete
+    <$> o!"cnc"
+    <*> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"params"
+    <*> o!"lincats"
+    <*> o!"lins"
+
+instance JSON ParamDef where
+  showJSON (ParamDef      p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
+  showJSON (ParamAliasDef p t)   = makeObj [("param", showJSON p), ("alias", showJSON t)]
+
+  readJSON o = ParamDef      <$> o!"param" <*> o!"values"
+    <|>        ParamAliasDef <$> o!"param" <*> o!"alias"
+
+instance JSON LincatDef where
+  showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
+
+  readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
+
+instance JSON LinDef where
+  showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
+
+  readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
+
+instance JSON LinType where
+  -- the basic types (Str, Float, Int) are encoded as strings:
+  showJSON (StrType)         = showJSON "Str"
+  showJSON (FloatType)       = showJSON "Float"
+  showJSON (IntType)         = showJSON "Int"
+  -- parameters are also encoded as strings:
+  showJSON (ParamType pt)    = showJSON pt
+  -- tables/tuples are encoded as JSON objects:
+  showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
+  showJSON (TupleType lts)   = makeObj [(".tuple",  showJSON lts)]
+  -- records are encoded as records:
+  showJSON (RecordType rows) = showJSON rows
+
+  readJSON o = StrType   <$ parseString "Str"   o
+    <|>        FloatType <$ parseString "Float" o
+    <|>        IntType   <$ parseString "Int"   o
+    <|>        ParamType <$> readJSON o
+    <|>        TableType  <$> o!".tblarg" <*> o!".tblval"
+    <|>        TupleType  <$> o!".tuple"
+    <|>        RecordType <$> readJSON o
+
+instance JSON LinValue where
+  showJSON (LiteralValue  l ) = showJSON l
+  -- most values are encoded as JSON objects:
+  showJSON (ParamConstant pv) = makeObj [(".param",    showJSON pv)]
+  showJSON (PredefValue   p ) = makeObj [(".predef",   showJSON p)]
+  showJSON (TableValue t tvs) = makeObj [(".tblarg",   showJSON t), (".tblrows", showJSON tvs)]
+  showJSON (TupleValue   lvs) = makeObj [(".tuple",    showJSON lvs)]
+  showJSON (VarValue      v ) = makeObj [(".var",      showJSON v)]
+  showJSON (ErrorValue    s ) = makeObj [(".error",    showJSON s)]
+  showJSON (Projection lv l ) = makeObj [(".project",  showJSON lv), (".label", showJSON l)]
+  showJSON (Selection  tv pv) = makeObj [(".select",   showJSON tv), (".key", showJSON pv)]
+  showJSON (VariantValue  vs) = makeObj [(".variants", showJSON vs)]
+  showJSON (PreValue pre def) = makeObj [(".pre",      showJSON pre),(".default", showJSON def)]
+  -- records are encoded directly as JSON records:
+  showJSON (RecordValue rows) = showJSON rows
+  -- concatenation is encoded as a JSON array:
+  showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
+    where flatten (ConcatValue v v') = flatten v . flatten v'
+          flatten  v                 = (v :)
+
+  readJSON o = LiteralValue  <$> readJSON o
+    <|>        ParamConstant <$> o!".param"
+    <|>        PredefValue   <$> o!".predef"
+    <|>        TableValue    <$> o!".tblarg"  <*> o!".tblrows"
+    <|>        TupleValue    <$> o!".tuple"
+    <|>        VarValue      <$> o!".var"
+    <|>        ErrorValue    <$> o!".error"
+    <|>        Projection    <$> o!".project" <*> o!".label"
+    <|>        Selection     <$> o!".select"  <*> o!".key"
+    <|>        VariantValue  <$> o!".variants"
+    <|>        PreValue      <$> o!".pre"     <*> o!".default"
+    <|>        RecordValue   <$> readJSON o
+    <|>        do vs <- readJSON o :: Result [LinValue]
+                  return (foldr1 ConcatValue vs)
+
+instance JSON LinLiteral where
+  -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
+  showJSON (StrConstant   s) = showJSON s
+  showJSON (FloatConstant f) = showJSON f
+  showJSON (IntConstant   n) = showJSON n
+
+  readJSON = readBasicJSON StrConstant IntConstant FloatConstant
+
+instance JSON LinPattern where
+  -- wildcards and patterns without arguments are encoded as strings:
+  showJSON (WildPattern) = showJSON "_"
+  showJSON (ParamPattern (Param p [])) = showJSON p
+  -- complex patterns are encoded as JSON objects:
+  showJSON (ParamPattern pv) = showJSON pv
+  -- and records as records:
+  showJSON (RecordPattern r) = showJSON r
+
+  readJSON o = do  p  <- parseString "_" o; return WildPattern
+    <|>        do  p  <- readJSON o; return (ParamPattern (Param p []))
+    <|>        ParamPattern  <$> readJSON o
+    <|>        RecordPattern <$> readJSON o
+
+instance JSON arg => JSON (Param arg) where
+  -- parameters without arguments are encoded as strings:
+  showJSON (Param p [])   = showJSON p
+  showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
+
+  readJSON o = Param <$> readJSON o <*> return []
+    <|>        Param <$> o!".paramid" <*> o!".args"
+
+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) = (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 (rawIdentS lbl)) value)
+
+instance JSON rhs => JSON (TableRow rhs) where
+  showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
+
+  readJSON o = TableRow <$> o!".pattern" <*> o!".value"
+
+
+-- *** Identifiers in Concrete Syntax
+
+instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON
+instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON
+instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON
+instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON
+instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
+
+
+--------------------------------------------------------------------------------
+-- ** Used in both Abstract and Concrete Syntax
+
+instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
+instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
+instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
+
+instance JSON VarId where
+  -- the anonymous variable is the underscore:
+  showJSON Anonymous = showJSON "_"
+  showJSON (VarId x) = showJSON x
+
+  readJSON o = do parseString "_" o; return Anonymous
+    <|>        VarId <$> readJSON o
+
+instance JSON QualId where
+  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 (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 [(showRawIdent f, showJSON v) | (f, v) <- fs]
+
+  readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (rawIdentS lbl, value)
+
+instance JSON FlagValue where
+  -- flag values are encoded as basic JSON types:
+  showJSON (Str s) = showJSON s
+  showJSON (Int i) = showJSON i
+  showJSON (Flt f) = showJSON f
+
+  readJSON = readBasicJSON Str Int Flt
+
+
+--------------------------------------------------------------------------------
+-- ** Convenience functions
+
+parseString :: String -> JSValue -> Result ()
+parseString s o = guard . (== s) =<< readJSON o
+
+(!) :: JSON a => JSValue -> String -> Result a
+obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
+            readJSON
+            (lookup key (assocsJSObject obj))
+
+assocsJSObject :: JSValue -> [(String, JSValue)]
+assocsJSObject (JSObject o) = fromJSObject o
+assocsJSObject (JSArray  _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
+assocsJSObject  jsvalue     = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
+
+
+readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
+                 (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
+readBasicJSON str int flt o
+  =   str        <$> readJSON o
+  <|> int_or_flt <$> readJSON o
+  where int_or_flt f | f == fromIntegral n = int n
+                     | otherwise           = flt f
+          where n = round f
--- a/src/compiler/GF/Grammar/Lexer.x
+++ b/src/compiler/GF/Grammar/Lexer.x
@@ -1,5 +1,6 @@
 -- -*- haskell -*-
 {
+{-# LANGUAGE CPP #-}
 module GF.Grammar.Lexer
         ( Token(..), Posn(..)
         , P, runP, runPartial, token, lexer, getPosn, failLoc
@@ -18,6 +19,7 @@ import qualified Data.Map as Map
 import Data.Word(Word8)
 import Data.Char(readLitChar)
 --import Debug.Trace(trace)
+import qualified Control.Monad.Fail as Fail
 }


@@ -33,7 +35,7 @@ $u = [.\n]                -- universal: any character

 :-
 "--" [.]* ; -- Toss single line comments
-"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; 
+"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;

 $white+ ;
@rsyms                          { tok ident }
@@ -136,7 +138,7 @@ data Token

 res = eitherResIdent
 eitherResIdent :: (Ident -> Token) -> Ident -> Token
-eitherResIdent tv s = 
+eitherResIdent tv s =
  case Map.lookup s resWords of
    Just t  -> t
    Nothing -> tv s
@@ -265,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 }
@@ -282,8 +284,16 @@ instance Monad P where
  (P m) >>= k = P $ \ s -> case m s of
                             POk s a          -> unP (k a) s
                             PFailed posn err -> PFailed posn err
+
+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail P where
  fail msg    = P $ \(_,AI posn _ _) -> PFailed posn msg

+
 runP :: P a -> BS.ByteString -> Either (Posn,String) a
 runP p bs = snd <$> runP' p (Pn 1 0,bs)

--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -6,7 +6,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/10/27 13:21:53 $ 
+-- > CVS $Date: 2005/10/27 13:21:53 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.15 $
 --
@@ -20,17 +20,17 @@ module GF.Grammar.Lookup (
           lookupOrigInfo,
           allOrigInfos,
           lookupResDef, lookupResDefLoc,
-           lookupResType, 
+           lookupResType,
           lookupOverload,
           lookupOverloadTypes,
-           lookupParamValues, 
+           lookupParamValues,
           allParamValues,
-           lookupAbsDef, 
-           lookupLincat, 
+           lookupAbsDef,
+           lookupLincat,
           lookupFunType,
           lookupCatContext,
           allOpers, allOpersTo
-	      ) where
+          ) where

 import GF.Data.Operations
 import GF.Infra.Ident
@@ -51,11 +51,11 @@ lock c = lockRecType c -- return
 unlock c = unlockRecord c -- return

 -- to look up a constant etc in a search tree --- why here? AR 29/5/2008
-lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b
+lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b
 lookupIdent c t =
-  case lookupTree showIdent c t of
-    Ok v  -> return v
-    Bad _ -> raise ("unknown identifier" +++ showIdent c)
+  case Map.lookup c t of
+    Just v  -> return v
+    Nothing -> raise ("unknown identifier" +++ showIdent c)

 lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
 lookupIdentInfo mo i = lookupIdent i (jments mo)
@@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
 lookupResDefLoc gr (m,c)
  | isPredefCat c = fmap noLoc (lock c defLinType)
  | otherwise     = look m c
-  where 
+  where
    look m c = do
      info <- lookupQIdentInfo gr (m,c)
      case info of
@@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c)
        ResOper _ Nothing  -> return (noLoc (Q (m,c)))
        CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
        CncCat _ _ _ _ _         -> fmap noLoc (lock c defLinType)
-      
+
        CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
        CncFun _                (Just ltr) _ _ -> return ltr

@@ -95,7 +95,7 @@ lookupResType gr (m,c) = do
    -- used in reused concrete
    CncCat _ _ _ _ _ -> return typeType
    CncFun (Just (cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val 
+          val' <- lock cat val
          return $ mkProd cont val' []
    AnyInd _ n        -> lookupResType gr (n,c)
    ResParam _ _      -> return typePType
@@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do
    -- used in reused concrete
    CncCat _ _ _ _ _ -> ret typeType
    CncFun (Just (cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val 
+          val' <- lock cat val
          ret $ mkProd cont val' []
    ResParam _ _      -> ret typePType
    ResValue (L _ t)  -> ret t
@@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do
    case info of
      ResOverload os tysts -> do
            tss <- mapM (\x -> lookupOverload gr (x,c)) os
-            return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | 
-                      (L _ ty,L _ tr) <- tysts] ++ 
+            return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
+                      (L _ ty,L _ tr) <- tysts] ++
                     concat tss

      AnyInd _ n  -> lookupOverload gr (n,c)
@@ -148,7 +148,7 @@ lookupOrigInfo gr (m,c) = do
 allOrigInfos :: Grammar -> ModuleName -> [(QIdent,Info)]
 allOrigInfos gr m = fromErr [] $ do
  mo <- lookupModule gr m
-  return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
+  return [((m,c),i) | (c,_) <- Map.toList (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]

 lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
 lookupParamValues gr c = do
@@ -166,11 +166,11 @@ allParamValues cnc ptyp =
    RecType r -> do
       let (ls,tys) = unzip $ sortByFst r
       tss <- mapM (allParamValues cnc) tys
-       return [R (zipAssign ls ts) | ts <- combinations tss]
+       return [R (zipAssign ls ts) | ts <- sequence tss]
    Table pt vt -> do
       pvs <- allParamValues cnc pt
       vvs <- allParamValues cnc vt
-       return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
+       return [V pt ts | ts <- sequence (replicate (length pvs) vvs)]
    _ -> raise (render ("cannot find parameter values for" <+> ptyp))
  where
    -- to normalize records and record types
@@ -216,7 +216,7 @@ lookupCatContext gr m c = do
 -- notice that it only gives the modules that are reachable and the opers that are included

 allOpers :: Grammar -> [(QIdent,Type,Location)]
-allOpers gr = 
+allOpers gr =
  [((m,op),typ,loc) |
      (m,mi)  <- maybe [] (allExtends gr) (greatestResource gr),
      (op,info)  <- Map.toList (jments mi),
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/11/11 16:38:00 $ 
+-- > CVS $Date: 2005/11/11 16:38:00 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.24 $
 --
@@ -22,17 +22,17 @@ import GF.Data.Operations
 import GF.Data.Str
 import GF.Infra.Ident
 import GF.Grammar.Grammar
--import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Grammar.Printer

 import Control.Monad.Identity(Identity(..))
 import qualified Data.Traversable as T(mapM)
+import qualified Data.Map as Map
 import Control.Monad (liftM, liftM2, liftM3)
--import Data.Char (isDigit)
 import Data.List (sortBy,nub)
 import Data.Monoid
 import GF.Text.Pretty(render,(<+>),hsep,fsep)
+import qualified Control.Monad.Fail as Fail

 -- ** Functions for constructing and analysing source code terms.

@@ -51,14 +51,14 @@ typeForm t =
    _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))

 typeFormCnc :: Type -> (Context, Type)
-typeFormCnc t = 
+typeFormCnc t =
  case t of
    Prod b x a t -> let (x', v) = typeFormCnc t
                    in ((b,x,a):x',v)
    _            -> ([],t)

 valCat :: Type -> Cat
-valCat typ = 
+valCat typ =
  let (_,cat,_) = typeForm typ
  in cat

@@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do  -- pessimistic choice
 contextOfType :: Monad m => Type -> m Context
 contextOfType typ = case typ of
  Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
-  _            -> return [] 
+  _            -> return []

 termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
 termForm t = case t of
@@ -108,8 +108,8 @@ termForm t = case t of
        return ((b,x):x', fun, args)
   App c a ->
     do (_,fun, args) <- termForm c
-        return ([],fun,args ++ [a]) 
-   _       -> 
+        return ([],fun,args ++ [a])
+   _       ->
     return ([],t,[])

 termFormCnc :: Term -> ([(BindType,Ident)], Term)
@@ -238,7 +238,7 @@ isPredefConstant t = case t of
  Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
  _                                               -> False

-checkPredefError :: Monad m => Term -> m Term
+checkPredefError :: Fail.MonadFail m => Term -> m Term
 checkPredefError t =
    case t of
      Error s -> fail ("Error: "++s)
@@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term
 mkTable tt t = foldr Table t tt

 mkCTable :: [(BindType,Ident)] -> Term -> Term
-mkCTable ids v = foldr ccase v ids where 
+mkCTable ids v = foldr ccase v ids where
  ccase (_,x) t = T TRaw [(PV x,t)]

 mkHypo :: Term -> Hypo
@@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of
    filter (`elem` (map fst r1)) (map fst r2) of
      [] -> return (RecType (r1 ++ r2))
      ls -> raise $ render ("clashing labels" <+> hsep ls)
-  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) 
+  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)

 --plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
@@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel,  typeStr)]

 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident
-mkFreshVar olds = varX (maxVarIndex olds + 1) 
+mkFreshVar olds = varX (maxVarIndex olds + 1)

 -- | trying to preserve a given symbol
 mkFreshVarX :: [Ident] -> Ident -> Ident
@@ -313,7 +313,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
 maxVarIndex :: [Ident] -> Int
 maxVarIndex = maximum . ((-1):) . map varIndex

-mkFreshVars :: Int -> [Ident] -> [Ident] 
+mkFreshVars :: Int -> [Ident] -> [Ident]
 mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]

 -- | quick hack for refining with var in editor
@@ -413,11 +413,11 @@ patt2term pt = case pt of
  PC c pp   -> mkApp (Con c) (map patt2term pp)
  PP c pp   -> mkApp (QC  c) (map patt2term pp)

-  PR r      -> R [assign l (patt2term p) | (l,p) <- r] 
+  PR r      -> R [assign l (patt2term p) | (l,p) <- r]
  PT _ p    -> patt2term p
  PInt i    -> EInt i
  PFloat i  -> EFloat i
-  PString s -> K s 
+  PString s -> K s

  PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
  PChar     -> appCons cChar  []                             --- an encoding
@@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op)

 -- | to define compositional term functions
 composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp co trm = 
+composOp co trm =
 case trm of
   App c a          -> liftM2 App (co c) (co a)
   Abs b x t        -> liftM (Abs b x) (co t)
@@ -552,19 +552,15 @@ strsFromTerm t = case t of
    v0 <- mapM (strsFromTerm . fst) vs
    c0 <- mapM (strsFromTerm . snd) vs
  --let vs' = zip v0 c0
-    return [strTok (str2strings def) vars | 
+    return [strTok (str2strings def) vars |
              def  <- d0,
-              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
-                                                          vv <- combinations v0]
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
+                                                          vv <- sequence v0]
           ]
  FV ts -> mapM strsFromTerm ts >>= return . concat
-  Strs ts -> mapM strsFromTerm ts >>= return . concat  
+  Strs ts -> mapM strsFromTerm ts >>= return . concat
  _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))

-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
-stringFromTerm :: Term -> String
-stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
-
 getTableType :: TInfo -> Err Type
 getTableType i = case i of
  TTyped ty -> return ty
@@ -594,11 +590,11 @@ noExist = FV []
 defaultLinType :: Type
 defaultLinType = mkRecType linLabel [typeStr]

-- normalize records and record types; put s first
+-- | normalize records and record types; put s first

 sortRec :: [(Label,a)] -> [(Label,a)]
 sortRec = sortBy ordLabel where
-  ordLabel (r1,_) (r2,_) = 
+  ordLabel (r1,_) (r2,_) =
    case (showIdent (label2ident r1), showIdent (label2ident r2)) of
      ("s",_) -> LT
      (_,"s") -> GT
@@ -608,9 +604,9 @@ sortRec = sortBy ordLabel where

 -- | dependency check, detecting circularities and returning topo-sorted list

-allDependencies :: (ModuleName -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]
-allDependencies ism b = 
-  [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
+allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
+allDependencies ism b =
+  [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
  where
    opersIn t = case t of
      Q  (n,c) | ism n -> [c]
@@ -634,7 +630,7 @@ topoSortJments (m,mi) = do
          return
          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
          (topoTest (allDependencies (==m) (jments mi)))
-  return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
+  return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])

 topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
 topoSortJments2 (m,mi) = do
@@ -644,4 +640,4 @@ topoSortJments2 (m,mi) = do
                                   <+> fsep (head cyc))))
           (topoTest2 (allDependencies (==m) (jments mi)))
  return
-    [[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
+    [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss]
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -24,6 +24,7 @@ import GF.Grammar.Lexer
 import GF.Compile.Update (buildAnyTree)
 import Data.List(intersperse)
 import Data.Char(isAlphaNum)
+import qualified Data.Map as Map
 import PGF(mkCId)

 }
@@ -139,7 +140,7 @@ ModHeader
  : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                               (mtype,id) = $2 ;
                                               (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing emptyBinTree) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }

 ComplMod :: { ModuleStatus }
 ComplMod 
--- a/src/compiler/GF/Grammar/PatternMatch.hs
+++ b/src/compiler/GF/Grammar/PatternMatch.hs
@@ -5,18 +5,19 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/10/12 12:38:29 $ 
+-- > CVS $Date: 2005/10/12 12:38:29 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.7 $
 --
 -- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
 -----------------------------------------------------------------------------

-module GF.Grammar.PatternMatch (matchPattern,
-		     testOvershadow, 
-		     findMatch,
-                     measurePatt
-		    ) where
+module GF.Grammar.PatternMatch (
+                                matchPattern,
+                                testOvershadow,
+                                findMatch,
+                                measurePatt
+                               ) where

 import GF.Data.Operations
 import GF.Grammar.Grammar
@@ -30,7 +31,7 @@ import GF.Text.Pretty
 --import Debug.Trace

 matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
-matchPattern pts term = 
+matchPattern pts term =
  if not (isInConstantForm term)
    then raise (render ("variables occur in" <+> pp term))
  else do
@@ -61,53 +62,56 @@ testOvershadow pts vs = do
 findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
 findMatch cases terms = case cases of
   [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
-   (patts,_):_ | length patts /= length terms -> 
-       raise (render ("wrong number of args for patterns :" <+> hsep patts <+> 
+   (patts,_):_ | length patts /= length terms ->
+       raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
                    "cannot take" <+> hsep terms))
   (patts,val):cc -> case mapM tryMatch (zip patts terms) of
       Ok substs -> return (val, concat substs)
       _         -> findMatch cc terms

 tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do 
+tryMatch (p,t) = do
  t' <- termForm t
  trym p t'
 where
-
-  isInConstantFormt = True -- tested already in matchPattern
  trym p t' =
    case (p,t') of
 --    (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05
      (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
-      (PW, _) | isInConstantFormt -> return [] -- optimization with wildcard
-      (PV x,  _) | isInConstantFormt -> return [(x,t)]
+      (PW, _) -> return [] -- optimization with wildcard
+      (PV x,([],K s,[])) -> return [(x,words2term (words s))]
+      (PV x,  _) -> return [(x,t)]
      (PString s, ([],K i,[])) | s==i -> return []
      (PInt s, ([],EInt i,[])) | s==i -> return []
      (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
-      (PC p pp, ([], Con f, tt)) | 
+      (PC p pp, ([], Con f, tt)) |
            p `eqStrIdent` f && length pp == length tt ->
         do matches <- mapM tryMatch (zip pp tt)
            return (concat matches)

-      (PP (q,p) pp, ([], QC (r,f), tt)) | 
+      (PP (q,p) pp, ([], QC (r,f), tt)) |
            -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
            p `eqStrIdent` f && length pp == length tt ->
         do matches <- mapM tryMatch (zip pp tt)
            return (concat matches)
      ---- hack for AppPredef bug
-      (PP (q,p) pp, ([], Q (r,f), tt)) | 
-            -- q `eqStrIdent` r && --- 
+      (PP (q,p) pp, ([], Q (r,f), tt)) |
+            -- q `eqStrIdent` r && ---
            p `eqStrIdent` f && length pp == length tt ->
         do matches <- mapM tryMatch (zip pp tt)
            return (concat matches)

      (PR r, ([],R r',[])) |
            all (`elem` map fst r') (map fst r) ->
-         do matches <- mapM tryMatch 
+         do matches <- mapM tryMatch
                            [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
            return (concat matches)
      (PT _ p',_) -> trym p' t'

+      (PAs x p',([],K s,[])) -> do
+         subst <- trym p' t'
+         return $ (x,words2term (words s)) : subst
+
      (PAs x p',_) -> do
         subst <- trym p' t'
         return $ (x,t) : subst
@@ -122,7 +126,7 @@ tryMatch (p,t) = do
      (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s

      (PRep p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq p1)) (PString "") 
+         trym (foldr (const (PSeq p1)) (PString "")
           [1..n]) t' | n <- [0 .. length s]
        ] >>
        return []
@@ -132,6 +136,11 @@ tryMatch (p,t) = do

      _ -> raise (render ("no match in case expr for" <+> t))

+  words2term []     = Empty
+  words2term [w]    = K w
+  words2term (w:ws) = C (K w) (words2term ws)
+
+
 matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
 --matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
 matchPSeq p1 p2 s = matchPSeq' (lengthBounds p1) p1 (lengthBounds p2) p2 s
@@ -209,4 +218,4 @@ isMatchingForms ps ts = all match (zip ps ts') where
  match _ = True
  ts' = map appForm ts

-}
+-}
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -1,365 +1,364 @@
----------------------------------------------------------------------
-- |
-- Module      : GF.Grammar.Printer
-- Maintainer  : Krasimir Angelov
-- Stability   : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-module GF.Grammar.Printer
-           ( -- ** Pretty printing
-             TermPrintQual(..)
-           , ppModule
-           , ppJudgement
-           , ppParams
-           , ppTerm
-           , ppPatt
-           , ppValue
-           , ppConstrs
-           , ppQIdent
-           , ppMeta
-           , getAbs
-           ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Grammar.Values
-import GF.Grammar.Grammar
-
-import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
-
-import GF.Text.Pretty
-import Data.Maybe (isNothing)
-import Data.List  (intersperse)
-import qualified Data.Map as Map
--import qualified Data.IntMap as IntMap
--import qualified Data.Set as Set
-import qualified Data.Array.IArray as Array
-
-data TermPrintQual 
-  = Terse | Unqualified | Qualified | Internal
-  deriving Eq                 
-
-instance Pretty Grammar where
-  pp = vcat . map (ppModule Qualified) . modules
-
-ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
-    hdr $$ 
-    nest 2 (ppOptions opts $$ 
-            vcat (map (ppJudgement q) (Map.toList jments)) $$
-            maybe empty (ppSequences q) mseqs) $$
-    ftr
-    where
-      hdr = complModDoc <+> modTypeDoc <+> '=' <+> 
-            hsep (intersperse (pp "**") $
-                  filter (not . isEmpty)  $ [ commaPunct ppExtends exts
-                                            , maybe empty ppWith with
-                                            , if null opens
-                                                then pp '{'
-                                                else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
-                                            ])
-
-      ftr = '}'
-
-      complModDoc =
-        case mstat of
-          MSComplete   -> empty
-          MSIncomplete -> pp "incomplete"
-
-      modTypeDoc =
-        case mtype of
-          MTAbstract         -> "abstract"  <+> mn
-          MTResource         -> "resource"  <+> mn
-          MTConcrete abs     -> "concrete"  <+> mn <+> "of" <+> abs
-          MTInterface        -> "interface" <+> mn
-          MTInstance ie      -> "instance"  <+> mn <+> "of" <+> ppExtends ie
-
-      ppExtends (id,MIAll        ) = pp id
-      ppExtends (id,MIOnly   incs) = id         <+> brackets (commaPunct pp incs)
-      ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
-      
-      ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
-
-ppOptions opts = 
-  "flags" $$
-  nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
-
-ppJudgement q (id, AbsCat pcont ) =
-  "cat" <+> id <+>
-  (case pcont of
-     Just (L _ cont) -> hsep (map (ppDecl q) cont)
-     Nothing         -> empty) <+> ';'
-ppJudgement q (id, AbsFun ptype _ pexp poper) =
-  let kind | isNothing pexp      = "data"
-           | poper == Just False = "oper"
-           | otherwise           = "fun"
-  in
-  (case ptype of
-     Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
-     Nothing        -> empty) $$
-  (case pexp of
-     Just []  -> empty
-     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
-     Nothing  -> empty)
-ppJudgement q (id, ResParam pparams _) = 
-  "param" <+> id <+>
-  (case pparams of
-     Just (L _ ps) -> '=' <+> ppParams q ps
-     _             -> empty) <+> ';'
-ppJudgement q (id, ResValue pvalue) = 
-  "-- param constructor" <+> id <+> ':' <+> 
-  (case pvalue of
-     (L _ ty) -> ppTerm q 0 ty) <+> ';'
-ppJudgement q (id, ResOper  ptype pexp) =
-  "oper" <+> id <+>
-  (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
-   case pexp  of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
-ppJudgement q (id, ResOverload ids defs) =
-  "oper" <+> id <+> '=' <+> 
-  ("overload" <+> '{' $$
-   nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
-   '}') <+> ';'
-ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
-  (case pcat of
-     Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
-     Nothing        -> empty) $$
-  (case pdef of
-     Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
-     Nothing        -> empty) $$
-  (case pref of
-     Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
-     Nothing        -> empty) $$
-  (case pprn of
-     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
-     Nothing        -> empty) $$
-  (case (mpmcfg,q) of
-     (Just (PMCFG prods funs),Internal)
-                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
-                       nest 2 (vcat (map ppProduction prods) $$
-                               ' ' $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> 
-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
-                                         (Array.assocs funs))) $$
-                       '}'
-     _              -> empty)
-ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
-  (case pdef of
-     Just (L _ e) -> let (xs,e') = getAbs e
-                     in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
-     Nothing      -> empty) $$
-  (case pprn of
-     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
-     Nothing        -> empty) $$
-  (case (mpmcfg,q) of
-     (Just (PMCFG prods funs),Internal)
-                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
-                       nest 2 (vcat (map ppProduction prods) $$
-                               ' ' $$
-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> 
-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
-                                         (Array.assocs funs))) $$
-                       '}'
-     _              -> empty)
-ppJudgement q (id, AnyInd cann mid) =
-  case q of
-    Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
-    _        -> empty
-
-instance Pretty Term where pp = ppTerm Unqualified 0
-
-ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
-                           in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
-ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
-                           ([],_) -> "table" <+> '{' $$
-	  		             nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
-			             '}'
-                           (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
-ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
-			       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
-			       '}'
-ppTerm q d (T (TComp  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
-		 	       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
-			       '}'
-ppTerm q d (T (TWild  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
-			       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
-			       '}'
-ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
-                              then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
-                              else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
-ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
-ppTerm q d (Let l e)    = let (ls,e') = getLet e
-                          in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
-ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
-ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
-ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+'  <+> ppTerm q 2 e2)
-ppTerm q d (S x y)     = case x of
-                           T annot xs -> let e = case annot of
-			                           TRaw     -> y
-			                           TTyped t -> Typed y t
-			                           TComp  t -> Typed y t
-			                           TWild  t -> Typed y t
-			                 in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
-			                    nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
-			                   '}'
-			   _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
-ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
-ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
-ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
-ppTerm q d (FV es)     = "variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
-ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
-ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
-ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
-ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)
-ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
-ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
-ppTerm q d (Cn id)     = pp id
-ppTerm q d (Vr id)     = pp id
-ppTerm q d (Q  id)     = ppQIdent q id
-ppTerm q d (QC id)     = ppQIdent q id
-ppTerm q d (Sort id)   = pp id
-ppTerm q d (K s)       = str s
-ppTerm q d (EInt n)    = pp n
-ppTerm q d (EFloat f)  = pp f
-ppTerm q d (Meta i)    = ppMeta i
-ppTerm q d (Empty)     = pp "[]"
-ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType
-ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+> 
-                                                       fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
-                                                             '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
-ppTerm q d (RecType xs)
-  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
-                           [cat] -> pp cat
-                           _     -> doc
-  | otherwise          = doc
-  where
-    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
-ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
-ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
-ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
-ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
-ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
-
-ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
-
-ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
-
-instance Pretty Patt where pp = ppPatt Unqualified 0
-
-ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
-ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
-ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
-ppPatt q d (PC f ps)    = if null ps
-                            then pp f
-                            else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
-ppPatt q d (PP f ps)    = if null ps
-                            then ppQIdent q f
-                            else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
-ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')
-ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
-ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
-ppPatt q d (PChar)      = pp '?'
-ppPatt q d (PChars s)   = brackets (str s)
-ppPatt q d (PMacro id)  = '#' <> id
-ppPatt q d (PM id)      = '#' <> ppQIdent q id
-ppPatt q d PW           = pp '_'
-ppPatt q d (PV id)      = pp id
-ppPatt q d (PInt n)     = pp n
-ppPatt q d (PFloat f)   = pp f
-ppPatt q d (PString s)  = str s
-ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
-ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
-ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
-
-ppValue :: TermPrintQual -> Int -> Val -> Doc
-ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging
-ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
-ppValue q d (VCn (_,c))   = pp c
-ppValue q d (VClos env e) = case e of
-                              Meta _ -> ppTerm q d e <> ppEnv env
-                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
-ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
-ppValue q d VType         = pp "Type"
-
-ppConstrs :: Constraints -> [Doc]
-ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
-
-ppEnv :: Env -> Doc
-ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
-
-str s = doubleQuotes s
-
-ppDecl q (_,id,typ)
-  | id == identW = ppTerm q 3 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
-
-ppDDecl q (_,id,typ)
-  | id == identW = ppTerm q 6 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
-
-ppQIdent :: TermPrintQual -> QIdent -> Doc
-ppQIdent q (m,id) =
-  case q of
-    Terse       ->          pp id
-    Unqualified ->          pp id
-    Qualified   -> m <> '.' <> id
-    Internal    -> m <> '.' <> id
-    
-
-instance Pretty Label where pp = pp . label2ident
-
-ppOpenSpec (OSimple id)   = pp id
-ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
-
-ppInstSpec (id,n) = parens (id <+> '=' <+> n)
-
-ppLocDef q (id, (mbt, e)) =
-  id <+>
-  (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
-
-ppBind (Explicit,v) = pp v
-ppBind (Implicit,v) = braces v
-
-ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
-
-ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
-
-ppProduction (Production fid funid args) =
-  ppFId fid <+> "->" <+> ppFunId funid <> 
-  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
-
-ppSequences q seqsArr
-  | null seqs || q /= Internal = empty
-  | otherwise                  = "sequences" <+> '{' $$
-                                 nest 2 (vcat (map ppSeq seqs)) $$
-                                 '}'
-  where
-    seqs = Array.assocs seqsArr
-
-commaPunct f ds = (hcat (punctuate "," (map f ds)))
-
-prec d1 d2 doc
-  | d1 > d2   = parens doc
-  | otherwise = doc
-
-getAbs :: Term -> ([(BindType,Ident)], Term)
-getAbs (Abs bt v e) = let (xs,e') = getAbs e
-                      in ((bt,v):xs,e')
-getAbs e            = ([],e)
-
-getCTable :: Term -> ([Ident], Term)
-getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
-                                in (v:vs,e')
-getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e
-                                in (identW:vs,e')
-getCTable e                   = ([],e)
-
-getLet :: Term -> ([LocalDef], Term)
-getLet (Let l e) = let (ls,e') = getLet e
-                   in (l:ls,e')
-getLet e         = ([],e)
-
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Grammar.Printer
+-- Maintainer  : Krasimir Angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+module GF.Grammar.Printer
+           ( -- ** Pretty printing
+             TermPrintQual(..)
+           , ppModule
+           , ppJudgement
+           , ppParams
+           , ppTerm
+           , ppPatt
+           , ppValue
+           , ppConstrs
+           , ppQIdent
+           , ppMeta
+           , getAbs
+           ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Grammar.Values
+import GF.Grammar.Grammar
+
+import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
+
+import GF.Text.Pretty
+import Data.Maybe (isNothing)
+import Data.List  (intersperse)
+import qualified Data.Map as Map
+--import qualified Data.IntMap as IntMap
+--import qualified Data.Set as Set
+import qualified Data.Array.IArray as Array
+
+data TermPrintQual
+  = Terse | Unqualified | Qualified | Internal
+  deriving Eq
+
+instance Pretty Grammar where
+  pp = vcat . map (ppModule Qualified) . modules
+
+ppModule :: TermPrintQual -> SourceModule -> Doc
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+    hdr $$
+    nest 2 (ppOptions opts $$
+            vcat (map (ppJudgement q) (Map.toList jments)) $$
+            maybe empty (ppSequences q) mseqs) $$
+    ftr
+    where
+      hdr = complModDoc <+> modTypeDoc <+> '=' <+>
+            hsep (intersperse (pp "**") $
+                  filter (not . isEmpty)  $ [ commaPunct ppExtends exts
+                                            , maybe empty ppWith with
+                                            , if null opens
+                                                then pp '{'
+                                                else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
+                                            ])
+
+      ftr = '}'
+
+      complModDoc =
+        case mstat of
+          MSComplete   -> empty
+          MSIncomplete -> pp "incomplete"
+
+      modTypeDoc =
+        case mtype of
+          MTAbstract         -> "abstract"  <+> mn
+          MTResource         -> "resource"  <+> mn
+          MTConcrete abs     -> "concrete"  <+> mn <+> "of" <+> abs
+          MTInterface        -> "interface" <+> mn
+          MTInstance ie      -> "instance"  <+> mn <+> "of" <+> ppExtends ie
+
+      ppExtends (id,MIAll        ) = pp id
+      ppExtends (id,MIOnly   incs) = id         <+> brackets (commaPunct pp incs)
+      ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
+
+      ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
+
+ppOptions opts =
+  "flags" $$
+  nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
+
+ppJudgement q (id, AbsCat pcont ) =
+  "cat" <+> id <+>
+  (case pcont of
+     Just (L _ cont) -> hsep (map (ppDecl q) cont)
+     Nothing         -> empty) <+> ';'
+ppJudgement q (id, AbsFun ptype _ pexp poper) =
+  let kind | isNothing pexp      = "data"
+           | poper == Just False = "oper"
+           | otherwise           = "fun"
+  in
+  (case ptype of
+     Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
+     Nothing        -> empty) $$
+  (case pexp of
+     Just []  -> empty
+     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
+     Nothing  -> empty)
+ppJudgement q (id, ResParam pparams _) =
+  "param" <+> id <+>
+  (case pparams of
+     Just (L _ ps) -> '=' <+> ppParams q ps
+     _             -> empty) <+> ';'
+ppJudgement q (id, ResValue pvalue) =
+  "-- param constructor" <+> id <+> ':' <+>
+  (case pvalue of
+     (L _ ty) -> ppTerm q 0 ty) <+> ';'
+ppJudgement q (id, ResOper  ptype pexp) =
+  "oper" <+> id <+>
+  (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
+   case pexp  of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
+ppJudgement q (id, ResOverload ids defs) =
+  "oper" <+> id <+> '=' <+>
+  ("overload" <+> '{' $$
+   nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
+   '}') <+> ';'
+ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
+  (case pcat of
+     Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
+     Nothing        -> empty) $$
+  (case pdef of
+     Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+     Nothing        -> empty) $$
+  (case pref of
+     Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+     Nothing        -> empty) $$
+  (case pprn of
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+     Nothing        -> empty) $$
+  (case (mpmcfg,q) of
+     (Just (PMCFG prods funs),Internal)
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
+                       nest 2 (vcat (map ppProduction prods) $$
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+                                         (Array.assocs funs))) $$
+                       '}'
+     _              -> empty)
+ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
+  (case pdef of
+     Just (L _ e) -> let (xs,e') = getAbs e
+                     in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
+     Nothing      -> empty) $$
+  (case pprn of
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+     Nothing        -> empty) $$
+  (case (mpmcfg,q) of
+     (Just (PMCFG prods funs),Internal)
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
+                       nest 2 (vcat (map ppProduction prods) $$
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+                                         (Array.assocs funs))) $$
+                       '}'
+     _              -> empty)
+ppJudgement q (id, AnyInd cann mid) =
+  case q of
+    Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
+    _        -> empty
+
+instance Pretty Term where pp = ppTerm Unqualified 0
+
+ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
+                           in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
+ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
+                           ([],_) -> "table" <+> '{' $$
+                                       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                     '}'
+                           (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
+ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                '}'
+ppTerm q d (T (TComp  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                               '}'
+ppTerm q d (T (TWild  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                '}'
+ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
+                              then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
+                              else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
+ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
+ppTerm q d (Let l e)    = let (ls,e') = getLet e
+                          in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
+ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
+ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
+ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+'  <+> ppTerm q 2 e2)
+ppTerm q d (S x y)     = case x of
+                           T annot xs -> let e = case annot of
+                                                   TRaw     -> y
+                                                   TTyped t -> Typed y t
+                                                   TComp  t -> Typed y t
+                                                   TWild  t -> Typed y t
+                                         in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
+                                            nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                           '}'
+                           _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
+ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
+ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
+ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
+ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
+ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
+ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)
+ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
+ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
+ppTerm q d (Cn id)     = pp id
+ppTerm q d (Vr id)     = pp id
+ppTerm q d (Q  id)     = ppQIdent q id
+ppTerm q d (QC id)     = ppQIdent q id
+ppTerm q d (Sort id)   = pp id
+ppTerm q d (K s)       = str s
+ppTerm q d (EInt n)    = pp n
+ppTerm q d (EFloat f)  = pp f
+ppTerm q d (Meta i)    = ppMeta i
+ppTerm q d (Empty)     = pp "[]"
+ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType
+ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+>
+                                                       fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
+                                                             '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
+ppTerm q d (RecType xs)
+  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
+                           [cat] -> pp cat
+                           _     -> doc
+  | otherwise          = doc
+  where
+    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
+ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
+ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
+
+ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
+
+ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
+
+instance Pretty Patt where pp = ppPatt Unqualified 0
+
+ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
+ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PC f ps)    = if null ps
+                            then pp f
+                            else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PP f ps)    = if null ps
+                            then ppQIdent q f
+                            else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')
+ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
+ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
+ppPatt q d (PChar)      = pp '?'
+ppPatt q d (PChars s)   = brackets (str s)
+ppPatt q d (PMacro id)  = '#' <> id
+ppPatt q d (PM id)      = '#' <> ppQIdent q id
+ppPatt q d PW           = pp '_'
+ppPatt q d (PV id)      = pp id
+ppPatt q d (PInt n)     = pp n
+ppPatt q d (PFloat f)   = pp f
+ppPatt q d (PString s)  = str s
+ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
+ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
+ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
+
+ppValue :: TermPrintQual -> Int -> Val -> Doc
+ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging
+ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
+ppValue q d (VCn (_,c))   = pp c
+ppValue q d (VClos env e) = case e of
+                              Meta _ -> ppTerm q d e <> ppEnv env
+                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
+ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
+ppValue q d VType         = pp "Type"
+
+ppConstrs :: Constraints -> [Doc]
+ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
+
+ppEnv :: Env -> Doc
+ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
+
+str s = doubleQuotes s
+
+ppDecl q (_,id,typ)
+  | id == identW = ppTerm q 3 typ
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppDDecl q (_,id,typ)
+  | id == identW = ppTerm q 6 typ
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppQIdent :: TermPrintQual -> QIdent -> Doc
+ppQIdent q (m,id) =
+  case q of
+    Terse       ->          pp id
+    Unqualified ->          pp id
+    Qualified   -> m <> '.' <> id
+    Internal    -> m <> '.' <> id
+
+
+instance Pretty Label where pp = pp . label2ident
+
+ppOpenSpec (OSimple id)   = pp id
+ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
+
+ppInstSpec (id,n) = parens (id <+> '=' <+> n)
+
+ppLocDef q (id, (mbt, e)) =
+  id <+>
+  (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
+
+ppBind (Explicit,v) = pp v
+ppBind (Implicit,v) = braces v
+
+ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
+
+ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
+ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
+
+ppProduction (Production fid funid args) =
+  ppFId fid <+> "->" <+> ppFunId funid <>
+  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
+
+ppSequences q seqsArr
+  | null seqs || q /= Internal = empty
+  | otherwise                  = "sequences" <+> '{' $$
+                                 nest 2 (vcat (map ppSeq seqs)) $$
+                                 '}'
+  where
+    seqs = Array.assocs seqsArr
+
+commaPunct f ds = (hcat (punctuate "," (map f ds)))
+
+prec d1 d2 doc
+  | d1 > d2   = parens doc
+  | otherwise = doc
+
+getAbs :: Term -> ([(BindType,Ident)], Term)
+getAbs (Abs bt v e) = let (xs,e') = getAbs e
+                      in ((bt,v):xs,e')
+getAbs e            = ([],e)
+
+getCTable :: Term -> ([Ident], Term)
+getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
+                                in (v:vs,e')
+getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e
+                                in (identW:vs,e')
+getCTable e                   = ([],e)
+
+getLet :: Term -> ([LocalDef], Term)
+getLet (Let l e) = let (ls,e') = getLet e
+                   in (l:ls,e')
+getLet e         = ([],e)
--- a/src/compiler/GF/Grammar/Values.hs
+++ b/src/compiler/GF/Grammar/Values.hs
@@ -5,22 +5,23 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/04/21 16:22:32 $ 
+-- > CVS $Date: 2005/04/21 16:22:32 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.7 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------

-module GF.Grammar.Values (-- ** Values used in TC type checking
-	       Val(..), Env,
-	       -- ** Annotated tree used in editing
+module GF.Grammar.Values (
+               -- ** Values used in TC type checking
+               Val(..), Env,
+               -- ** Annotated tree used in editing
               Binds, Constraints, MetaSubst,
-	       -- ** For TC
-	       valAbsInt, valAbsFloat, valAbsString, vType,
-	       isPredefCat,
-	       eType, 
-	      ) where
+               -- ** For TC
+               valAbsInt, valAbsFloat, valAbsString, vType,
+               isPredefCat,
+               eType,
+              ) where

 import GF.Infra.Ident
 import GF.Grammar.Grammar
--- a/src/compiler/GF/Haskell.hs
+++ b/src/compiler/GF/Haskell.hs
@@ -40,6 +40,9 @@ tvar = TId
 tcon0 = TId
 tcon c = foldl TAp (TId c)

+lets [] e = e
+lets ds e = Lets ds e
+
 let1 x xe e = Lets [(x,xe)] e
 single x = List [x]

@@ -113,7 +116,8 @@ instance Pretty Exp where
          Op e1 op e2 -> hang (ppB e1<+>op) 2 (ppB e2)
          Lets bs e -> sep ["let"<+>vcat [hang (x<+>"=") 2 xe|(x,xe)<-bs],
                            "in" <+>e]
-          LambdaCase alts -> hang "\\case" 4 (vcat [p<+>"->"<+>e|(p,e)<-alts])
+          LambdaCase alts ->
+              hang "\\case" 2 (vcat [hang (p<+>"->") 2 e|(p,e)<-alts])
          _ -> ppB e

      ppB e = case flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as))
--- a/src/compiler/GF/Infra/CheckM.hs
+++ b/src/compiler/GF/Infra/CheckM.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/04/21 16:22:33 $ 
+-- > CVS $Date: 2005/04/21 16:22:33 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.5 $
 --
@@ -14,10 +14,10 @@

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

 import GF.Data.Operations
@@ -32,6 +32,7 @@ import System.FilePath(makeRelative)
 import Control.Parallel.Strategies(parList,rseq,using)
 import Control.Monad(liftM,ap)
 import Control.Applicative(Applicative(..))
+import qualified Control.Monad.Fail as Fail

 type Message = Doc
 type Error   = Message
@@ -53,6 +54,9 @@ instance Monad Check where
                 (ws,Success x) -> unCheck (g x) {-ctxt-} ws
                 (ws,Fail msg)  -> (ws,Fail msg)

+instance Fail.MonadFail Check where
+  fail = raise
+
 instance Applicative Check where
  pure = return
  (<*>) = ap
@@ -137,10 +141,10 @@ checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
  where f' (k,v) = fmap ((,)k) (f k v)

 {-
-checkMapRecover f mp = do 
+checkMapRecover f mp = do
  let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
  case [s | (_,Bad s) <- xs] of
-    ss@(_:_) -> checkError (text (unlines ss)) 
+    ss@(_:_) -> checkError (text (unlines ss))
    _   -> do
      let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
      if not (all null ss) then checkWarn (text (unlines ss)) else return ()
--- a/src/compiler/GF/Infra/Ident.hs
+++ b/src/compiler/GF/Infra/Ident.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/11/15 11:43:33 $ 
+-- > CVS $Date: 2005/11/15 11:43:33 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.8 $
 --
@@ -13,18 +13,18 @@
 -----------------------------------------------------------------------------

 module GF.Infra.Ident (-- ** Identifiers
-              ModuleName(..), moduleNameS,
-	      Ident, ident2utf8, showIdent, prefixIdent,
-              -- *** Normal identifiers (returned by the parser)
-	      identS, identC, identW,
-              -- *** Special identifiers for internal use
-              identV, identA, identAV,
-	      argIdent, isArgIdent, getArgIndex,
-              varStr, varX, isWildIdent, varIndex,
-              -- *** Raw identifiers
-              RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-              isPrefixOf, showRawIdent
-	     ) where
+  ModuleName(..), moduleNameS,
+  Ident, ident2utf8, showIdent, prefixIdent,
+  -- *** Normal identifiers (returned by the parser)
+  identS, identC, identW,
+  -- *** Special identifiers for internal use
+  identV, identA, identAV,
+  argIdent, isArgIdent, getArgIndex,
+  varStr, varX, isWildIdent, varIndex,
+  -- *** Raw identifiers
+  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+  isPrefixOf, showRawIdent
+) where

 import qualified Data.ByteString.UTF8 as UTF8
 import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m

 -- | the constructors labelled /INTERNAL/ are
 -- internal representation never returned by the parser
-data Ident = 
+data Ident =
   IC  {-# UNPACK #-} !RawIdent                                           -- ^ raw identifier after parsing, resolved in Rename
 | IW                                                                     -- ^ wildcard
 --
@@ -54,7 +54,7 @@ data Ident =
 | IV  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ variable
 | IA  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ argument of cat at position
 | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int   -- ^ /INTERNAL/ argument of cat with bindings at position
-- 
+--
  deriving (Eq, Ord, Show, Read)

 -- | Identifiers are stored as UTF-8-encoded bytestrings.
@@ -70,14 +70,13 @@ rawIdentS = Id . pack
 rawIdentC = Id
 showRawIdent = unpack . rawId2utf8

-prefixRawIdent (Id x) (Id y) = Id (BS.append x y) 
+prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
 isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y

 instance Binary RawIdent where
  put = put . rawId2utf8
  get = fmap rawIdentC get

-
 -- | This function should be used with care, since the returned ByteString is
 -- UTF-8-encoded.
 ident2utf8 :: Ident -> UTF8.ByteString
@@ -88,6 +87,7 @@ ident2utf8 i = case i of
  IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
  IW -> pack "_"

+ident2raw :: Ident -> RawIdent
 ident2raw = Id . ident2utf8

 showIdent :: Ident -> String
@@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i

 instance Pretty Ident where pp = pp . showIdent

+instance Pretty RawIdent where pp = pp . showRawIdent
+
 identS :: String -> Ident
 identS = identC . rawIdentS

 identC :: RawIdent -> Ident
 identW :: Ident

-
 prefixIdent :: String -> Ident -> Ident
 prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8

@@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident
 identA :: RawIdent -> Int -> Ident
 identAV:: RawIdent -> Int -> Int -> Ident

-(identC, identV, identA, identAV, identW) = 
+(identC, identV, identA, identAV, identW) =
    (IC,     IV,     IA,     IAV,     IW)

 -- | to mark argument variables
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -2,13 +2,13 @@ module GF.Infra.Option
    (
     -- ** Command line options
     -- *** Option types
-     Options, 
-     Flags(..), 
-     Mode(..), Phase(..), Verbosity(..), 
-     OutputFormat(..), 
+     Options,
+     Flags(..),
+     Mode(..), Phase(..), Verbosity(..),
+     OutputFormat(..),
     SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
     Dump(..), Pass(..), Recomp(..),
-     outputFormatsExpl, 
+     outputFormatsExpl,
     -- *** Option parsing
     parseOptions, parseModuleOptions, fixRelativeLibPaths,
     -- *** Option pretty-printing
@@ -44,9 +44,10 @@ import Data.Set (Set)
 import qualified Data.Set as Set

 import PGF.Internal(Literal(..))
+import qualified Control.Monad.Fail as Fail

 usageHeader :: String
-usageHeader = unlines 
+usageHeader = unlines
 ["Usage: gf [OPTIONS] [FILE [...]]",
  "",
  "How each FILE is handled depends on the file name suffix:",
@@ -87,9 +88,12 @@ data Phase = Preproc | Convert | Compile | Link
  deriving (Show,Eq,Ord)

 data OutputFormat = FmtPGFPretty
-                  | FmtJavaScript 
-                  | FmtPython 
-                  | FmtHaskell 
+                  | FmtCanonicalGF
+                  | FmtCanonicalJson
+                  | FmtJavaScript
+                  | FmtJSON
+                  | FmtPython
+                  | FmtHaskell
                  | FmtJava
                  | FmtProlog
                  | FmtBNF
@@ -98,37 +102,42 @@ data OutputFormat = FmtPGFPretty
                  | FmtNoLR
                  | FmtSRGS_XML
                  | FmtSRGS_XML_NonRec
-                  | FmtSRGS_ABNF 
+                  | FmtSRGS_ABNF
                  | FmtSRGS_ABNF_NonRec
-                  | FmtJSGF 
-                  | FmtGSL 
+                  | FmtJSGF
+                  | FmtGSL
                  | FmtVoiceXML
                  | FmtSLF
                  | FmtRegExp
                  | FmtFA
  deriving (Eq,Ord)

-data SISRFormat = 
+data SISRFormat =
    -- | SISR Working draft 1 April 2003
    --   <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
-    SISR_WD20030401    
+    SISR_WD20030401
  | SISR_1_0
 deriving (Show,Eq,Ord)

 data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
  deriving (Show,Eq,Ord)

-data CFGTransform = CFGNoLR 
+data CFGTransform = CFGNoLR
                  | CFGRegular
-                  | CFGTopDownFilter 
-                  | CFGBottomUpFilter 
+                  | CFGTopDownFilter
+                  | CFGBottomUpFilter
                  | CFGStartCatOnly
                  | CFGMergeIdentical
                  | CFGRemoveCycles
  deriving (Show,Eq,Ord)

-data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
-                   | HaskellConcrete | HaskellVariants
+data HaskellOption = HaskellNoPrefix
+                   | HaskellGADT
+                   | HaskellLexical
+                   | HaskellConcrete
+                   | HaskellVariants
+                   | HaskellData
+                   | HaskellPGF2
  deriving (Show,Eq,Ord)

 data Warning = WarnMissingLincat
@@ -192,7 +201,7 @@ instance Show Options where
 parseOptions :: ErrorMonad err =>
                [String]                   -- ^ list of string arguments
             -> err (Options, [FilePath])
-parseOptions args 
+parseOptions args
  | not (null errs) = errors errs
  | otherwise       = do opts <- concatOptions `fmap` liftErr (sequence optss)
                         return (opts, files)
@@ -204,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
                   -> err Options
 parseModuleOptions args = do
  (opts,nonopts) <- parseOptions args
-  if null nonopts 
+  if null nonopts
    then return opts
    else errors $ map ("Non-option among module options: " ++) nonopts

@@ -277,7 +286,7 @@ defaultFlags = Flags {
      optOptimizations   = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
      optOptimizePGF     = False,
      optSplitPGF        = False,
-      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, 
+      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
                                         CFGTopDownFilter, CFGMergeIdentical],
      optLibraryPath     = [],
      optStartCat        = Nothing,
@@ -297,7 +306,7 @@ defaultFlags = Flags {
 -- | Option descriptions
 {-# NOINLINE optDescr #-}
 optDescr :: [OptDescr (Err Options)]
-optDescr = 
+optDescr =
    [
     Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
     Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
@@ -323,43 +332,44 @@ optDescr =
 --   Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
 --   Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
     Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
-     Option ['f'] ["output-format"] (ReqArg outFmt "FMT") 
+     Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
        (unlines ["Output format. FMT can be one of:",
-                  "Multiple concrete: pgf (default), js, pgf_pretty, prolog, python, ...", -- gar,
+                  "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
+                  "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
                  "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
                  "Abstract only: haskell, ..."]), -- prolog_abs,
-     Option [] ["sisr"] (ReqArg sisrFmt "FMT") 
+     Option [] ["sisr"] (ReqArg sisrFmt "FMT")
        (unlines ["Include SISR tags in generated speech recognition grammars.",
                  "FMT can be one of: old, 1.0"]),
-     Option [] ["haskell"] (ReqArg hsOption "OPTION") 
-            ("Turn on an optional feature when generating Haskell data types. OPTION = " 
+     Option [] ["haskell"] (ReqArg hsOption "OPTION")
+            ("Turn on an optional feature when generating Haskell data types. OPTION = "
             ++ concat (intersperse " | " (map fst haskellOptionNames))),
-     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") 
+     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
            "Treat CAT as a lexical category.",
-     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") 
+     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
            "Treat CAT as a literal category.",
-     Option ['D'] ["output-dir"] (ReqArg outDir "DIR") 
+     Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
           "Save output files (other than .gfo files) in DIR.",
-     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") 
+     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
           "Overrides the value of GF_LIB_PATH.",
-     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) 
+     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
                 "Always recompile from source.",
-     Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer)) 
+     Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
                 "(default) Recompile from source if the source is newer than the .gfo file.",
-     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) 
+     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
                 "Never recompile from source, if there is already .gfo file.",
     Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
     Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
-     Option ['n'] ["name"] (ReqArg name "NAME") 
+     Option ['n'] ["name"] (ReqArg name "NAME")
           (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
                     "with suffixes depending on the formats, and, when relevant, ",
                     "internally in the output."]),
     Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
     Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
-     Option [] ["preproc"] (ReqArg preproc "CMD") 
+     Option [] ["preproc"] (ReqArg preproc "CMD")
                 (unlines ["Use CMD to preprocess input files.",
                           "Multiple preprocessors can be used by giving this option multiple times."]),
-     Option [] ["coding"] (ReqArg coding "ENCODING") 
+     Option [] ["coding"] (ReqArg coding "ENCODING")
                ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
     Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
     Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
@@ -367,7 +377,7 @@ optDescr =
     Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
     Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
     Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
-     Option [] ["optimize"] (ReqArg optimize "OPT") 
+     Option [] ["optimize"] (ReqArg optimize "OPT")
                "Select an optimization package. OPT = all | values | parametrize | none",
     Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
                "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
@@ -442,7 +452,7 @@ optDescr =
       optimize    x = case lookup x optimizationPackages of
                         Just p  -> set $ \o -> o { optOptimizations = p }
                         Nothing -> fail $ "Unknown optimization package: " ++ x
-                         
+
       optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
       splitPGF x = set $ \o -> o { optSplitPGF = x }

@@ -466,9 +476,12 @@ outputFormats :: [(String,OutputFormat)]
 outputFormats = map fst outputFormatsExpl

 outputFormatsExpl :: [((String,OutputFormat),String)]
-outputFormatsExpl = 
+outputFormatsExpl =
    [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
+     (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
+     (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
     (("js",           FmtJavaScript),"JavaScript (whole grammar)"),
+     (("json",         FmtJSON),"JSON (whole grammar)"),
     (("python",       FmtPython),"Python (whole grammar)"),
     (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
     (("java",         FmtJava),"Java (abstract syntax)"),
@@ -496,11 +509,11 @@ instance Read OutputFormat where
    readsPrec = lookupReadsPrec outputFormats

 optimizationPackages :: [(String, Set Optimization)]
-optimizationPackages = 
+optimizationPackages =
    [("all",         Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
     ("values",      Set.fromList [OptStem,OptCSE,OptExpand]),
     ("noexpand",    Set.fromList [OptStem,OptCSE]),
-     
+
     -- deprecated
     ("all_subs",    Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
     ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
@@ -508,7 +521,7 @@ optimizationPackages =
    ]

 cfgTransformNames :: [(String, CFGTransform)]
-cfgTransformNames = 
+cfgTransformNames =
    [("nolr",         CFGNoLR),
     ("regular",      CFGRegular),
     ("topdown",      CFGTopDownFilter),
@@ -523,7 +536,9 @@ haskellOptionNames =
     ("gadt",     HaskellGADT),
     ("lexical",  HaskellLexical),
     ("concrete", HaskellConcrete),
-     ("variants", HaskellVariants)]
+     ("variants", HaskellVariants),
+     ("data",     HaskellData),
+     ("pgf2",     HaskellPGF2)]

 -- | This is for bacward compatibility. Since GHC 6.12 we
 -- started using the native Unicode support in GHC but it
@@ -540,7 +555,7 @@ lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs]
 lookupReadsPrec :: [(String,a)] -> Int -> ReadS a
 lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x]

-onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a)
+onOff :: Fail.MonadFail m => (Bool -> m a) -> Bool -> ArgDescr (m a)
 onOff f def = OptArg g "[on,off]"
  where g ma = maybe (return def) readOnOff ma >>= f
        readOnOff x = case map toLower x of
@@ -548,8 +563,8 @@ onOff f def = OptArg g "[on,off]"
                        "off" -> return False
                        _     -> fail $ "Expected [on,off], got: " ++ show x

-readOutputFormat :: Monad m => String -> m OutputFormat
-readOutputFormat s = 
+readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
+readOutputFormat s =
    maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats

 -- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -561,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of
    isPathSep :: Char -> Bool
    isPathSep c = c == ':' || c == ';'

-- 
+--
 -- * Convenience functions for checking options
 --

@@ -583,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
 isLexicalCat :: Options -> String -> Bool
 isLexicalCat opts c = Set.member c (flag optLexicalCats opts)

-- 
+--
 -- * Convenience functions for setting options
 --

@@ -614,8 +629,8 @@ readMaybe s = case reads s of

 toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
 toEnumBounded i = let mi = minBound
-                      ma = maxBound `asTypeOf` mi                      
-                   in if i >= fromEnum mi && i <= fromEnum ma 
+                      ma = maxBound `asTypeOf` mi
+                   in if i >= fromEnum mi && i <= fromEnum ma
                        then Just (toEnum i `asTypeOf` mi)
                        else Nothing

--- a/src/compiler/GF/Infra/SIO.hs
+++ b/src/compiler/GF/Infra/SIO.hs
@@ -42,6 +42,7 @@ import qualified GF.Command.Importing as GF(importGrammar, importSource)
 #ifdef C_RUNTIME
 import qualified PGF2
 #endif
+import qualified Control.Monad.Fail as Fail

 -- * The SIO monad

@@ -58,6 +59,9 @@ instance Monad SIO where
  return x = SIO (const (return x))
  SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h

+instance Fail.MonadFail SIO where
+  fail = lift0 . fail
+
 instance Output SIO where
  ePutStr = lift0 . ePutStr
  ePutStrLn = lift0 . ePutStrLn
--- a/src/compiler/GF/Infra/UseIO.hs
+++ b/src/compiler/GF/Infra/UseIO.hs
@@ -159,6 +159,9 @@ instance ErrorMonad IO where
                                then h (ioeGetErrorString e)
                                else ioError e
 {-
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail
+
 instance Functor IOE where fmap = liftM

 instance Applicative IOE where
@@ -170,7 +173,15 @@ instance  Monad IOE where
  IOE c >>= f = IOE $ do 
                  x <- c          -- Err a
                  appIOE $ err raise f x         -- f :: a -> IOE a
+
+ #if !(MIN_VERSION_base(4,13,0))
  fail = raise
+ #endif
+
+instance Fail.MonadFail IOE where
+  fail = raise
+
+
 -}

 -- | Print the error message and return a default value if the IO operation 'fail's
--- a/src/compiler/GF/Interactive.hs
+++ b/src/compiler/GF/Interactive.hs
@@ -1,10 +1,10 @@
 {-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}
 -- | GF interactive mode
 module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where
+
 import Prelude hiding (putStrLn,print)
 import qualified Prelude as P(putStrLn)
 import GF.Command.Interpreter(CommandEnv(..),mkCommandEnv,interpretCommandLine)
--import GF.Command.Importing(importSource,importGrammar)
 import GF.Command.Commands(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands)
 import GF.Command.CommonCommands(commonCommands,extend)
 import GF.Command.SourceCommands
@@ -12,16 +12,13 @@ import GF.Command.CommandInfo
 import GF.Command.Help(helpCommand)
 import GF.Command.Abstract
 import GF.Command.Parse(readCommandLine,pCommand)
-import GF.Data.Operations (Err(..),done)
+import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)
 import GF.Grammar hiding (Ident,isPrefixOf)
 import GF.Infra.UseIO(ioErrorText,putStrLnE)
 import GF.Infra.SIO
 import GF.Infra.Option
 import qualified System.Console.Haskeline as Haskeline
--import GF.Text.Coding(decodeUnicode,encodeUnicode)
-
--import GF.Compile.Coding(codeTerm)

 import PGF
 import PGF.Internal(abstract,funs,lookStartCat,emptyPGF)
@@ -41,6 +38,8 @@ import GF.Server(server)
 #endif

 import GF.Command.Messages(welcome)
+-- Provides an orphan instance of MonadFail for StateT in ghc versions < 8
+import Control.Monad.Trans.Instances ()

 -- | Run the GF Shell in quiet mode (@gf -run@).
 mainRunGFI :: Options -> [FilePath] -> IO ()
@@ -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
@@ -102,7 +102,7 @@ timeIt act =

 -- | Optionally show how much CPU time was used to run an IO action
 optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
-optionallyShowCPUTime opts act 
+optionallyShowCPUTime opts act
  | not (verbAtLeast opts Normal) = act
  | otherwise = do (dt,r) <- timeIt act
                   liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
@@ -165,7 +165,7 @@ execute1' s0 =
      do execute . lines =<< lift (restricted (readFile w))
         continue
      where
-        execute [] = done
+        execute []           = return ()
        execute (line:lines) = whenM (execute1' line) (execute lines)

    execute_history _   =
@@ -290,8 +290,8 @@ importInEnv opts files =
         pgf1 <- importGrammar pgf0 opts' files
         if (verbAtLeast opts Normal)
           then putStrLnFlush $
-                    unwords $ "\nLanguages:" : map showCId (languages pgf1)
-           else done
+                  unwords $ "\nLanguages:" : map showCId (languages pgf1)
+           else return ()
         return pgf1

 tryGetLine = do
@@ -366,7 +366,7 @@ wordCompletion gfenv (left,right) = do
    pgf    = multigrammar gfenv
    cmdEnv = commandenv gfenv
    optLang opts = valCIdOpts "lang" (head (languages pgf)) opts
-    optType opts = 
+    optType opts =
      let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
      in case readType str of
           Just ty -> ty
@@ -413,7 +413,7 @@ wc_type = cmd_name
    option x y (c  :cs)
      | isIdent c       = option x y cs
      | otherwise       = cmd x cs
-      
+
    optValue x y ('"':cs) = str x y cs
    optValue x y cs       = cmd x cs

@@ -431,9 +431,9 @@ wc_type = cmd_name
      where
        x1 = take (length x - length y - d) x
        x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
-        
+
        cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
-	        [x] -> Just x
+                [x] -> Just x
                _   -> Nothing

    isIdent c = c == '_' || c == '\'' || isAlphaNum c
--- a/src/compiler/GF/Interactive2.hs
+++ b/src/compiler/GF/Interactive2.hs
@@ -10,16 +10,13 @@ import GF.Command.CommandInfo
 import GF.Command.Help(helpCommand)
 import GF.Command.Abstract
 import GF.Command.Parse(readCommandLine,pCommand)
-import GF.Data.Operations (Err(..),done)
+import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)

 import GF.Infra.UseIO(ioErrorText,putStrLnE)
 import GF.Infra.SIO
 import GF.Infra.Option
 import qualified System.Console.Haskeline as Haskeline
--import GF.Text.Coding(decodeUnicode,encodeUnicode)
-
--import GF.Compile.Coding(codeTerm)

 import qualified PGF2 as C
 import qualified PGF as H
@@ -61,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

 {-
@@ -104,7 +102,7 @@ timeIt act =

 -- | Optionally show how much CPU time was used to run an IO action
 optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
-optionallyShowCPUTime opts act 
+optionallyShowCPUTime opts act
  | not (verbAtLeast opts Normal) = act
  | otherwise = do (dt,r) <- timeIt act
                   liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
@@ -167,7 +165,7 @@ execute1' s0 =
         continue
      where
        execute :: [String] -> ShellM ()
-        execute [] = done
+        execute [] = return ()
        execute (line:lines) = whenM (execute1' line) (execute lines)

    execute_history _   =
@@ -282,14 +280,14 @@ importInEnv opts files =
    _ | flag optRetainResource opts ->
          putStrLnE "Flag -retain is not supported in this shell"
    [file] | takeExtensions file == ".pgf" -> importPGF file
-    [] -> done
+    [] -> return ()
    _ -> do putStrLnE "Can only import one .pgf file"
  where
    importPGF file =
      do gfenv <- get
         case multigrammar gfenv of
           Just _ -> putStrLnE "Discarding previous grammar"
-           _ -> done
+           _ -> return ()
         pgf1 <- lift $ readPGF2 file
         let gfenv' = gfenv { pgfenv = pgfEnv pgf1 }
         when (verbAtLeast opts Normal) $
@@ -361,7 +359,7 @@ wordCompletion gfenv (left,right) = do
    CmplIdent _ pref
      -> case mb_pgf of
           Just pgf -> ret (length pref)
-                           [Haskeline.simpleCompletion name 
+                           [Haskeline.simpleCompletion name
                            | name <- C.functions pgf,
                              isPrefixOf pref name]
           _ -> ret (length pref) []
@@ -372,7 +370,7 @@ wordCompletion gfenv (left,right) = do
    cmdEnv = commandenv gfenv
 {-
    optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts
-    optType opts = 
+    optType opts =
      let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts
      in case H.readType str of
           Just ty -> ty
@@ -419,7 +417,7 @@ wc_type = cmd_name
    option x y (c  :cs)
      | isIdent c       = option x y cs
      | otherwise       = cmd x cs
-      
+
    optValue x y ('"':cs) = str x y cs
    optValue x y cs       = cmd x cs

@@ -437,9 +435,9 @@ wc_type = cmd_name
      where
        x1 = take (length x - length y - d) x
        x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
-        
+
        cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
-	        [x] -> Just x
+                [x] -> Just x
                _   -> Nothing

    isIdent c = c == '_' || c == '\'' || isAlphaNum c
--- a/src/compiler/GF/Main.hs
+++ b/src/compiler/GF/Main.hs
@@ -16,18 +16,21 @@ import Data.Version
 import System.Directory
 import System.Environment (getArgs)
 import System.Exit
-import GF.System.Console (setConsoleEncoding)
+import GHC.IO.Encoding
+-- 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
+  setLocaleEncoding utf8
+  -- setConsoleEncoding
  uncurry mainOpts =<< getOptions

 -- | Get and parse GF command line arguments. Fix relative paths.
 -- Calls 'getArgs' and 'parseOptions'.
+getOptions :: IO (Options, [FilePath])
 getOptions = do
  args <- getArgs
  case parseOptions args of
@@ -43,7 +46,7 @@ getOptions = do
 -- the options it invokes 'mainGFC', 'mainGFI', 'mainRunGFI', 'mainServerGFI',
 -- or it just prints version/usage info.
 mainOpts :: Options -> [FilePath] -> IO ()
-mainOpts opts files = 
+mainOpts opts files =
    case flag optMode opts of
      ModeVersion     -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
      ModeHelp        -> putStrLn helpMessage
--- a/src/compiler/GF/Server.hs
+++ b/src/compiler/GF/Server.hs
@@ -6,7 +6,7 @@ import qualified Data.Map as M
 import Control.Applicative -- for GHC<7.10
 import Control.Monad(when)
 import Control.Monad.State(StateT(..),get,gets,put)
-import Control.Monad.Error(ErrorT(..),Error(..))
+import Control.Monad.Except(ExceptT(..),runExceptT)
 import System.Random(randomRIO)
 --import System.IO(stderr,hPutStrLn)
 import GF.System.Catch(try)
@@ -108,9 +108,9 @@ handle_fcgi execute1 state0 stateM cache =

 -- * Request handler
 -- | Handler monad
-type HM s a = StateT (Q,s) (ErrorT Response IO) a
+type HM s a = StateT (Q,s) (ExceptT Response IO) a
 run :: HM s Response -> (Q,s) -> IO (s,Response)
-run m s = either bad ok =<< runErrorT (runStateT m s)
+run m s = either bad ok =<< runExceptT (runStateT m s)
  where
    bad resp = return (snd s,resp)
    ok (resp,(qs,state)) = return (state,resp)
@@ -123,12 +123,12 @@ put_qs qs = do state <- get_state; put (qs,state)
 put_state state = do qs <- get_qs; put (qs,state)

 err :: Response -> HM s a
-err e = StateT $ \ s -> ErrorT $ return $ Left e
+err e = StateT $ \ s -> ExceptT $ return $ Left e

 hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
 hmbracket_ pre post m =
    do s <- get
-       e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s
+       e <- liftIO $ bracket_ pre post $ runExceptT $ runStateT m s
       case e of
         Left resp -> err resp
         Right (a,s) -> do put s;return a
@@ -407,9 +407,6 @@ resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n"
 resp500 msg  = Response 500 [plain,xo] $ "Internal error: "++msg++"\n"
 resp501 msg  = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n"

-instance Error Response where
-  noMsg = resp500 "no message"
-  strMsg = resp500

 -- * Content types
 plain = ct "text/plain" ""
--- a/src/compiler/GF/Speech/FiniteState.hs
+++ b/src/compiler/GF/Speech/FiniteState.hs
@@ -5,37 +5,37 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
-- > CVS $Date: 2005/11/10 16:43:44 $ 
+-- > CVS $Date: 2005/11/10 16:43:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.16 $
 --
 -- A simple finite state network module.
 -----------------------------------------------------------------------------
 module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
-			      startState, finalStates,
-			      states, transitions,
+                              startState, finalStates,
+                              states, transitions,
                              isInternal,
-			      newFA, newFA_,
-			      addFinalState,
-			      newState, newStates,
+                              newFA, newFA_,
+                              addFinalState,
+                              newState, newStates,
                              newTransition, newTransitions,
                              insertTransitionWith, insertTransitionsWith,
-			      mapStates, mapTransitions,
+                              mapStates, mapTransitions,
                              modifyTransitions,
-                              nonLoopTransitionsTo, nonLoopTransitionsFrom, 
+                              nonLoopTransitionsTo, nonLoopTransitionsFrom,
                              loops,
                              removeState,
                              oneFinalState,
                              insertNFA,
                              onGraph,
-			      moveLabelsToNodes, removeTrivialEmptyNodes,
+                              moveLabelsToNodes, removeTrivialEmptyNodes,
                              minimize,
                              dfa2nfa,
                              unusedNames, renameStates,
-			      prFAGraphviz, faToGraphviz) where
+                              prFAGraphviz, faToGraphviz) where

 import Data.List
-import Data.Maybe 
+import Data.Maybe
 --import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l))
 newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
 newTransitions es = onGraph (newEdges es)

-insertTransitionWith :: Eq n => 
+insertTransitionWith :: Eq n =>
                        (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
 insertTransitionWith f t = onGraph (insertEdgeWith f t)

-insertTransitionsWith :: Eq n => 
+insertTransitionsWith :: Eq n =>
                         (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
-insertTransitionsWith f ts fa = 
+insertTransitionsWith f ts fa =
    foldl' (flip (insertTransitionWith f)) fa ts

 mapStates :: (a -> c) -> FA n a b -> FA n c b
@@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names
 -- | Gets all incoming transitions to a given state, excluding
 -- transtions from the state itself.
 nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsTo s fa = 
+nonLoopTransitionsTo s fa =
    [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s]

 nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsFrom s fa = 
+nonLoopTransitionsFrom s fa =
    [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s]

 loops :: Eq n => n -> FA n a b -> [b]
@@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names
 renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
    where (ns,rest) = splitAt (length (nodes g)) supply
          newNodes = Map.fromList (zip (map fst (nodes g)) ns)
-	  newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
+          newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
          s' = newName s
          fs' = map newName fs

@@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into
          -> (State, State) -- ^ States to insert between
          -> NFA a -- ^ NFA to insert.
          -> NFA a
-insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) 
+insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
    = FA (newEdges es g') s1 fs1
-    where 
+    where
    es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
    (g',ren) = mergeGraphs g1 g2

@@ -182,9 +182,9 @@ oneFinalState nl el fa =
 moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
 moveLabelsToNodes = onGraph f
  where f g@(Graph c _ _) = Graph c' ns (concat ess)
-	    where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
-		  (c',is') = mapAccumL fixIncoming c is
-		  (ns,ess) = unzip (concat is')
+         where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
+               (c',is') = mapAccumL fixIncoming c is
+               (ns,ess) = unzip (concat is')


 -- | Remove empty nodes which are not start or final, and have
@@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
 --   This is not done if the pointed-to node is a final node.
 skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
 skipSimpleEmptyNodes fa = onGraph og fa
-  where 
+  where
  og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es')
    where
    es' = concatMap changeEdge es
    info = nodeInfo g
-    changeEdge e@(f,t,()) 
+    changeEdge e@(f,t,())
      | isNothing (getNodeLabel info t)
       -- && (i * o <= i + o)
        && not (isFinal fa t)
@@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa
 where
 f g = if Set.null rns then g else f (removeNodes rns g)
  where info = nodeInfo g
-        rns = Set.fromList [ n | (n,_) <- nodes g, 
+        rns = Set.fromList [ n | (n,_) <- nodes g,
                             isInternal fa n,
-                             inDegree info n == 0 
+                             inDegree info n == 0
                             || outDegree info n == 0]

-fixIncoming :: (Ord n, Eq a) => [n] 
+fixIncoming :: (Ord n, Eq a) => [n]
            -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
            -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
                                                      -- incoming edges.
 fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
  where ls = nub $ map edgeLabel es
-	(cs',cs'') = splitAt (length ls) cs
-	newNodes = zip cs' ls
-	es' = [ (x,n,()) | x <- map fst newNodes ]
-	-- separate cyclic and non-cyclic edges
-	(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-	          -- keep all incoming non-cyclic edges with the right label
-	to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-	          -- for each cyclic edge with the right label, 
-	          -- add an edge from each of the new nodes (including this one)
-		    ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
-	newContexts = [ (v, to v) | v <- newNodes ]
+        (cs',cs'') = splitAt (length ls) cs
+        newNodes = zip cs' ls
+        es' = [ (x,n,()) | x <- map fst newNodes ]
+        -- separate cyclic and non-cyclic edges
+        (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
+                  -- keep all incoming non-cyclic edges with the right label
+        to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
+                  -- for each cyclic edge with the right label,
+                  -- add an edge from each of the new nodes (including this one)
+                  ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
+        newContexts = [ (v, to v) | v <- newNodes ]

 --alphabet :: Eq b => Graph n a (Maybe b) -> [b]
 --alphabet = nub . catMaybes . map edgeLabel . edges
@@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
                             (ns',es') = (Set.toList ns, Set.toList es)
                             final = filter isDFAFinal ns'
                             fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
- 		          in renameStates [0..] fa
+                         in renameStates [0..] fa
  where info = nodeInfo g
 --        reach = nodesReachable out
-	start = closure info $ Set.singleton s
+        start = closure info $ Set.singleton s
        isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
-	h currentStates oldStates es
-	    | Set.null currentStates = (oldStates,es)
-	    | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
-	    where 
-	    allOldStates = oldStates `Set.union` currentStates
+        h currentStates oldStates es
+            | Set.null currentStates = (oldStates,es)
+            | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
+            where
+            allOldStates = oldStates `Set.union` currentStates
            (newStates,es') = new (Set.toList currentStates) Set.empty es
-	    uniqueNewStates = newStates Set.\\ allOldStates
-        -- Get the sets of states reachable from the given states 
+            uniqueNewStates = newStates Set.\\ allOldStates
+        -- Get the sets of states reachable from the given states
        -- by consuming one symbol, and the associated edges.
        new [] rs es = (rs,es)
        new (n:ns) rs es = new ns rs' es'
@@ -281,7 +281,7 @@ closure info x = closure_ x x
  where closure_ acc check | Set.null check = acc
                           | otherwise = closure_ acc' check'
            where
-            reach = Set.fromList [y | x <- Set.toList check, 
+            reach = Set.fromList [y | x <- Set.toList check,
                                      (_,y,Nothing) <- getOutgoing info x]
            acc' = acc `Set.union` reach
            check' = reach Set.\\ acc
@@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,
 reverseNFA :: NFA a -> NFA a
 reverseNFA (FA g s fs) = FA g''' s' [s]
    where g' = reverseGraph g
-	  (g'',s') = newNode () g'
-	  g''' = newEdges [(s',f,Nothing) | f <- fs] g''
+          (g'',s') = newNode () g'
+          g''' = newEdges [(s',f,Nothing) | f <- fs] g''

 dfa2nfa :: DFA a -> NFA a
 dfa2nfa = mapTransitions Just
@@ -313,13 +313,13 @@ prFAGraphviz  = Dot.prGraphviz . faToGraphviz
 --prFAGraphviz_  = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show

 faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
-faToGraphviz (FA (Graph _ ns es) s f) 
+faToGraphviz (FA (Graph _ ns es) s f)
    = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
   where mkNode (n,l) = Dot.Node (show n) attrs
-	     where attrs = [("label",l)]
-			   ++ if n == s then [("shape","box")] else []
-			   ++ if n `elem` f then [("style","bold")] else []
-	 mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
+          where attrs = [("label",l)]
+                 ++ if n == s then [("shape","box")] else []
+                 ++ if n `elem` f then [("style","bold")] else []
+         mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]

 --
 -- * Utilities
--- a/Show More
+++ b/Show More