Change Data.Text to String as a test, seemingly makes no difference.

Bul ✓
Cat ✗
Chi ✓
Dan ✓
Dut ✓
Eng ✓
Est ✓
Fin ✓
Fre ✗
Ger ✓
Hin ✓
Ita ✗
Jpn ✓
Lav ✓
Nor ✓
Pol ✓
Ron ✓
Snd ✗
Spa ✓
Swe ✓
Tha ✓
Urd ✓

Passed 18 | Failed 4 | Total 22

.github/workflows/build-all-versions.yml

@@ -0,0 +1,95 @@
+# 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: ["3.2"]
+        ghc:
+          - "8.6.5"
+          - "8.8.3"
+          - "8.10.1"
+        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: actions/setup-haskell@v1.1.4
+      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: ["2.3.3"]
+        ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4"]
+        # 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: actions/setup-haskell@v1.1.4
+      name: Setup Haskell Stack
+      with:
+        # ghc-version: ${{ matrix.ghc }}
+        stack-version: ${{ matrix.stack }}
+
+    - uses: actions/cache@v1
+      name: Cache ~/.stack
+      with:
+        path: ~/.stack
+        key: ${{ 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

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

@@ -0,0 +1,185 @@
+name: Build Binary Packages
+
+on:
+  workflow_dispatch:
+  release:
+
+jobs:
+
+# ---
+
+  ubuntu:
+    name: Build Ubuntu package
+    runs-on: ubuntu-18.04
+    # strategy:
+    #   matrix:
+    #     ghc: ["8.6.5"]
+    #     cabal: ["2.4"]
+
+    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.sha }}-ubuntu
+        path: dist/gf_*.deb
+        if-no-files-found: error
+
+# ---
+
+  macos:
+    name: Build macOS package
+    runs-on: macos-10.15
+    strategy:
+      matrix:
+        ghc: ["8.6.5"]
+        cabal: ["2.4"]
+
+    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.sha }}-macos
+        path: dist/gf-*.pkg
+        if-no-files-found: error
+
+# ---
+
+  windows:
+    name: Build Windows package
+    runs-on: windows-2019
+    strategy:
+      matrix:
+        ghc: ["8.6.5"]
+        cabal: ["2.4"]
+
+    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
+
+    - name: Build Java bindings
+      shell: msys2 {0}
+      run: |
+        export PATH="${PATH}:/c/Program Files/Java/jdk8u275-b01/bin"
+        cd src/runtime/java
+        make \
+          JNI_INCLUDES="-I \"/c/Program Files/Java/jdk8u275-b01/include\" -I \"/c/Program Files/Java/jdk8u275-b01/include/win32\" -I \"/mingw64/include\" -D__int64=int64_t" \
+          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.8/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.sha }}-windows
+        path: C:\tmp-dist\*
+        if-no-files-found: error

.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@master
+
+    - 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/*

.gitignore

@@ -5,7 +5,15 @@
 *.jar
 *.gfo
 *.pgf
+*.lpgf
+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 +52,19 @@ cabal.sandbox.config
 .stack-work
 DATA_DIR
 
+stack*.yaml.lock
+
 # 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

README.md

@@ -2,8 +2,6 @@
 
 # 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:
 

RELEASE.md

@@ -0,0 +1,64 @@
+# 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
+
+1. Run `make sdist`
+2. Upload the package, either:
+    1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file `dist/gf-X.Y.tar.gz`
+    2. **via Cabal (≥2.4)**: `cabal upload dist/gf-X.Y.tar.gz`
+3. 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.

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

bin/build-binary-dist.sh

@@ -1,15 +1,18 @@
 #! /bin/bash
 
-### This script builds a binary distribution of GF from the source
+### This script builds a binary distribution of GF from source.
-### package that this script is a part of. It assumes that you have installed
+### It assumes that you have Haskell and Cabal installed.
-### the Haskell Platform, version 2013.2.0.0 or 2012.4.0.0.
+### Two binary package formats are supported (specified with the FMT env var):
-### Two binary package formats are supported: plain tar files (.tar.gz) and
+### - plain tar files (.tar.gz)
-### OS X Installer packages (.pkg).
+### - 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
+        # A hack for Python on macOS to find the PGF modules
-	pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
+        pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
-	pydest="$destdir/Library/Python/$pyver/site-packages"
+        pydest="$destdir/Library/Python/$pyver/site-packages"
-	mkdir -p "$pydest"
+        mkdir -p "$pydest"
-	ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$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}install -w "$ghc" --only-dependencies -fserver -fc-runtime $extra
-cabal configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
+${cabal}configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
-DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib" cabal build
+${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
 
 ## 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
+        targz="$name-bin-$hw-$os.tar.gz"     # the final tar file
-	tar -C "$destdir/$prefix" -zcf "dist/$targz" .
+        tar --directory "$destdir/$prefix" --gzip --create --file "dist/$targz" .
-	echo "Created $targz, consider renaming it to something more user friendly"
+        echo "Created $targz"
-	;;
+        ;;
     pkg)
-	pkg=$name.pkg
+        pkg=$name.pkg
-	pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
+        pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
-	echo "Created $pkg"
+        echo "Created $pkg"
 esac
 
+## Cleanup
 rm -r "$destdir"

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

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 class="text-muted">Contribute</h6>
-        </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$

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

debian/changelog

@@ -1,8 +1,26 @@
+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
 

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

debian/rules

@@ -1,6 +1,6 @@
 #!/usr/bin/make -f
 
-%: 
+%:
 	+dh $@
 
 #dh_shlibdeps has a problem finding which package some of the Haskell
@@ -13,21 +13,6 @@
 override_dh_shlibdeps:
 	dh_shlibdeps --dpkg-shlibdeps-params=--ignore-missing-info
 
-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
-
-override_dh_auto_clean:
-	rm -fr dist/build
-	-cd src/runtime/python && rm -fr build
-	-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
@@ -35,13 +20,27 @@ override_dh_auto_configure:
 	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
 
+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
+	echo $(SET_LDL)
+	-$(SET_LDL) cabal build
+
 override_dh_auto_install:
-	LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs cabal copy --destdir=$(CURDIR)/debian/gf
+	$(SET_LDL) 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
+	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
+	-cd src/runtime/python && rm -fr build
+	-cd src/runtime/java && make clean
+	-cd src/runtime/c && make clean
+
 override_dh_auto_test:
 ifneq (nocheck,$(filter nocheck,$(DEB_BUILD_OPTIONS)))
 	true

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

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

doc/gf-developers.t2t

@@ -391,6 +391,8 @@ bindings are found in the ``src/runtime/python`` and ``src/runtime/java``
 directories, respecively. Compile them by following the instructions in
 the ``INSTALL`` files in those directories.
 
+The Python library can also be installed from PyPI using `pip install pgf`.
+
 == Compilation of RGL ==
 
 As of 2018-07-26, the RGL is distributed separately from the GF compiler and runtimes.
@@ -405,13 +407,13 @@ 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``
+If you do not have Haskell installed, you can use the simple build script ``Setup.sh``
-(or ``Make.bat`` for Windows).
+(or ``Setup.bat`` for Windows).
 
 
 == Creating binary distribution packages ==

doc/gf-people.md

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

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>

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>

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.

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 {
-
+				background-color:#eee;
-			pre.python   {background-color:#ffc; display: none}
+				margin-top: 1em;
-			pre.haskell  {background-color:#ffc; display: block}
+				padding: 0.5em 1em;
-			pre.java     {background-color:#ffc; display: none}
+			}
-			pre.csharp   {background-color:#ffc; display: none}
+			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">
+		<div class="container-fluid" style="max-width: 1200px">
-		<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>
+		<div class="header sticky-top border-bottom py-3 bg-white">
-		
+			<a href=".." title="Home">
-		Choose a language: <a href="#haskell">Haskell</a> <a href="#python">Python</a> <a href="#java">Java</a> <a href="#csharp">C#</a>
+			  <img src="../doc/Logos/gf1.svg" height="120px" class="float-md-right ml-3 mb-3 bg-white" alt="GF Logo">
-		</span>
+			</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 
+<p>Note that depending on the grammar it is absolutely possible that for
-a single sentence you might get infinitely many trees. 
+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 
+There is also the function <tt>parseWithHeuristics</tt> which
-takes two more paramaters which let you to have a better control 
+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 
+There is also the method <tt>parseWithHeuristics</tt> which
-takes two more paramaters which let you to have a better control 
+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 
+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. 
+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 
+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. 
+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 
+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. 
+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>
-

doc/tutorial/gf-tutorial.t2t

@@ -618,32 +618,32 @@ and **semantic definitions**.
 
 
 
-#NEW
+% #NEW
-
+%
-==Slides==
+% ==Slides==
-
+%
-You can chop this tutorial into a set of slides by the command
+% You can chop this tutorial into a set of slides by the command
-```
+% ```
-  htmls gf-tutorial.html
+%   htmls gf-tutorial.html
-```
+% ```
-where the program ``htmls`` is distributed with GF (see below), in
+% where the program ``htmls`` is distributed with GF (see below), in
-
+%
-  [``GF/src/tools/Htmls.hs`` http://grammaticalframework.org/src/tools/Htmls.hs]
+%   [``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``.
+% 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
+% 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.
+% 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 =
+  lin AppV2 subj v2 obj =
-    {s = subj.s ++ tv.s ! subj.n ++ obj.s ++ tv.part} ;
+    {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
+However, type-incorrect commands are rejected by the typecheck:
-is shown and no tree is returned:
 ```
-  > parse "dim the fan" | put_tree -typecheck
+  > parse "dim the fan"
-
+  The parsing is successful but the type checking failed with error(s):
-  Error in tree UCommand (CAction ? 0 dim (DKindOne fan)) :
+    Couldn't match expected type Device light
-    (? 0 <> fan) (? 0 <> 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.
-2. Perform random and exhaustive generation, with and without
-``solve`` filtering.
 
 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:

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

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:
+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**.
-- [GF releases](https://github.com/GrammaticalFramework/gf-core/releases)
-- [RGL releases](https://github.com/GrammaticalFramework/gf-rgl/releases)
 
 ### 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)

download/index-3.11.md

@@ -0,0 +1,182 @@
+---
+title: Grammatical Framework Download and Installation
+...
+
+**GF 3.11** was released on ... December 2020.
+
+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/RELEASE-3.11)
+
+#### Debian/Ubuntu
+
+To install the package use:
+```
+sudo dpkg -i gf_3.11.deb
+```
+
+The Ubuntu `.deb` packages should work on Ubuntu 16.04, 18.04 and similar Linux distributions.
+
+#### macOS
+
+To install the package, just double-click it and follow the installer instructions.
+
+The packages should work on at least 10.13 (High Sierra) and 10.14 (Mojave).
+
+#### 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 the latest release from source
+
+[GF is on Hackage](http://hackage.haskell.org/package/gf), so under
+normal circumstances the procedure is fairly simple:
+
+1.  Install a recent version of the [Haskell Platform](http://hackage.haskell.org/platform) (see note below)
+2.  `cabal update`
+3.  On Linux: install some C libraries from your Linux distribution (see note below)
+4.  `cabal install gf`
+
+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
+
+**Installation location**
+
+The above steps installs 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
+```
+
+**Build tools**
+
+In order to compile GF you need the build tools **Alex** and **Happy**.
+These can be installed via Cabal, e.g.:
+
+```
+cabal install alex happy
+```
+
+or obtained by other means, depending on your OS.
+
+**Haskeline**
+
+GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which
+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`
+
+**GHC version**
+
+The GF source code has been updated to compile with GHC versions 7.10 through to 8.8.
+
+## Installing from the latest developer source code
+
+If you haven't already, clone the repository with:
+
+```
+git clone https://github.com/GrammaticalFramework/gf-core.git
+```
+
+If you've already cloned the repository previously, update with:
+
+```
+git pull
+```
+
+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)

download/index.html

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

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

download/release-3.11.md

@@ -0,0 +1,40 @@
+---
+title: GF 3.11 Release Notes
+date: ... December 2020
+...
+
+## 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 400 changes have been pushed to GF core
+since the release of GF 3.10 in December 2018.
+
+## General
+
+- Make the test suite work again.
+- Compatibility with new versions of GHC, including multiple Stack files for the different versions.
+- Updates to build scripts and CI.
+- Bug fixes.
+
+## GF compiler and run-time library
+
+- Huge improvements in time & space requirements for grammar compilation (pending [#87](https://github.com/GrammaticalFramework/gf-core/pull/87)).
+- Add CoNLL output to `visualize_tree` shell command.
+- Add canonical GF as output format in the compiler.
+- Add PGF JSON as output format in the compiler.
+- Deprecate JavaScript runtime in favour of updated [TypeScript runtime](https://github.com/GrammaticalFramework/gf-typescript).
+- Improvements to Haskell export.
+- 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.

gf.cabal

@@ -1,5 +1,5 @@
 name: gf
-version: 3.10
+version: 3.10.4-git
 
 cabal-version: >= 1.22
 build-type: Custom
@@ -81,7 +81,15 @@ Library
                  random,
                  pretty,
                  mtl,
-                 exceptions
+                 exceptions,
+                 fail,
+                 -- For compatability with ghc < 8
+                 -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
+                 transformers-compat,
+                 ghc-prim,
+                 text,
+                 hashable,
+                 unordered-containers
   hs-source-dirs: src/runtime/haskell
 
   other-modules:
@@ -97,12 +105,12 @@ Library
 --if impl(ghc>=7.8)
 --  ghc-options: +RTS -A20M -RTS
   ghc-prof-options: -fprof-auto
-  extensions:
 
   exposed-modules:
     PGF
     PGF.Internal
     PGF.Haskell
+    LPGF
 
   other-modules:
     PGF.Data
@@ -141,8 +149,8 @@ Library
 
 ---- GF compiler as a library:
 
-  build-depends: filepath, directory, time, time-compat,
+  build-depends: filepath, directory>=1.2, time,
-                 process, haskeline, parallel>=3
+                 process, haskeline, parallel>=3, json
 
   hs-source-dirs: src/compiler
   exposed-modules:
@@ -150,6 +158,7 @@ Library
     GF.Support
     GF.Text.Pretty
     GF.Text.Lexing
+    GF.Grammar.Canonical
 
   other-modules:
     GF.Main GF.Compiler GF.Interactive
@@ -172,15 +181,14 @@ 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.Predef
     GF.Compile.Compute.Value
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
     GF.Compile.GeneratePMCFG
+    GF.Compile.GrammarToLPGF
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
     GF.Compile.Optimize
@@ -188,7 +196,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
@@ -207,6 +218,7 @@ Library
     GF.Data.ErrM
     GF.Data.Graph
     GF.Data.Graphviz
+    GF.Data.IntMapBuilder
     GF.Data.Relation
     GF.Data.Str
     GF.Data.Utilities
@@ -267,7 +279,7 @@ Library
     cpp-options: -DC_RUNTIME
 
   if flag(server)
-    build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7, json,
+    build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7,
                    cgi>=3001.2.2.0
     if flag(network-uri)
       build-depends: network-uri>=2.6, network>=2.6
@@ -347,3 +359,402 @@ test-suite gf-tests
   hs-source-dirs: testsuite
   build-depends:  base>=4.3 && <5, Cabal>=1.8, directory, filepath, process
   default-language:    Haskell2010
+
+test-suite lpgf
+  type: exitcode-stdio-1.0
+  main-is: test.hs
+  hs-source-dirs:
+    src/compiler
+    src/runtime/haskell
+    testsuite/lpgf
+  other-modules:
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF
+    GF.Command.Abstract
+    GF.Command.CommandInfo
+    GF.Command.Commands
+    GF.Command.CommonCommands
+    GF.Command.Help
+    GF.Command.Importing
+    GF.Command.Interpreter
+    GF.Command.Messages
+    GF.Command.Parse
+    GF.Command.SourceCommands
+    GF.Command.TreeOperations
+    GF.Compile
+    GF.Compile.CFGtoPGF
+    GF.Compile.CheckGrammar
+    GF.Compile.Compute.ConcreteNew
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
+    GF.Compile.ConcreteToHaskell
+    GF.Compile.ExampleBased
+    GF.Compile.Export
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToCanonical
+    GF.Compile.GrammarToLPGF
+    GF.Compile.GrammarToPGF
+    GF.Compile.Multi
+    GF.Compile.Optimize
+    GF.Compile.PGFtoHaskell
+    GF.Compile.PGFtoJava
+    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.ToAPI
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.RConcrete
+    GF.Compile.TypeCheck.TC
+    GF.Compile.Update
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compiler
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.Graph
+    GF.Data.Graphviz
+    GF.Data.IntMapBuilder
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Data.XML
+    GF.Grammar
+    GF.Grammar.Analyse
+    GF.Grammar.Binary
+    GF.Grammar.BNFC
+    GF.Grammar.Canonical
+    GF.Grammar.CanonicalJSON
+    GF.Grammar.CFG
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Parser
+    GF.Grammar.PatternMatch
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.ShowTerm
+    GF.Grammar.Unify
+    GF.Grammar.Values
+    GF.Haskell
+    GF.Infra.BuildInfo
+    GF.Infra.CheckM
+    GF.Infra.Concurrency
+    GF.Infra.Dependencies
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.SIO
+    GF.Infra.UseIO
+    GF.Interactive
+    GF.JavaScript.AbsJS
+    GF.JavaScript.PrintJS
+    GF.Main
+    GF.Quiz
+    GF.Speech.CFGToFA
+    GF.Speech.FiniteState
+    GF.Speech.GSL
+    GF.Speech.JSGF
+    GF.Speech.PGFToCFG
+    GF.Speech.PrRegExp
+    GF.Speech.RegExp
+    GF.Speech.SISR
+    GF.Speech.SLF
+    GF.Speech.SRG
+    GF.Speech.SRGS_ABNF
+    GF.Speech.SRGS_XML
+    GF.Speech.VoiceXML
+    GF.Support
+    GF.System.Catch
+    GF.System.Concurrency
+    GF.System.Console
+    GF.System.Directory
+    GF.System.Process
+    GF.System.Signal
+    GF.Text.Clitics
+    GF.Text.Coding
+    GF.Text.Lexing
+    GF.Text.Pretty
+    GF.Text.Transliterations
+    LPGF
+    PGF
+    PGF.Binary
+    PGF.ByteCode
+    PGF.CId
+    PGF.Data
+    PGF.Expr
+    PGF.Forest
+    PGF.Generate
+    PGF.Internal
+    PGF.Linearize
+    PGF.Macros
+    PGF.Morphology
+    PGF.OldBinary
+    PGF.Optimize
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Printer
+    PGF.Probabilistic
+    PGF.Tree
+    PGF.TrieMap
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Utilities
+    PGF.VisualizeTree
+    Paths_gf
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+  build-depends:
+    ansi-terminal,
+    array,
+    base>=4.6 && <5,
+    bytestring,
+    containers,
+    directory,
+    filepath,
+    ghc-prim,
+    hashable,
+    haskeline,
+    json,
+    mtl,
+    parallel>=3,
+    pretty,
+    process,
+    random,
+    terminfo,
+    text,
+    time,
+    transformers-compat,
+    unix,
+    unordered-containers,
+    utf8-string
+  default-language: Haskell2010
+
+benchmark lpgf-bench
+  type: exitcode-stdio-1.0
+  main-is: bench.hs
+  hs-source-dirs:
+    src/compiler
+    src/runtime/haskell
+    testsuite/lpgf
+  other-modules:
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF
+    GF.Command.Abstract
+    GF.Command.CommandInfo
+    GF.Command.Commands
+    GF.Command.CommonCommands
+    GF.Command.Help
+    GF.Command.Importing
+    GF.Command.Interpreter
+    GF.Command.Messages
+    GF.Command.Parse
+    GF.Command.SourceCommands
+    GF.Command.TreeOperations
+    GF.Compile
+    GF.Compile.CFGtoPGF
+    GF.Compile.CheckGrammar
+    GF.Compile.Compute.ConcreteNew
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
+    GF.Compile.ConcreteToHaskell
+    GF.Compile.ExampleBased
+    GF.Compile.Export
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToCanonical
+    GF.Compile.GrammarToLPGF
+    GF.Compile.GrammarToPGF
+    GF.Compile.Multi
+    GF.Compile.Optimize
+    GF.Compile.PGFtoHaskell
+    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoJava
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.ToAPI
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.RConcrete
+    GF.Compile.TypeCheck.TC
+    GF.Compile.Update
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compiler
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.Graph
+    GF.Data.Graphviz
+    GF.Data.IntMapBuilder
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Data.XML
+    GF.Grammar
+    GF.Grammar.Analyse
+    GF.Grammar.BNFC
+    GF.Grammar.Binary
+    GF.Grammar.CFG
+    GF.Grammar.Canonical
+    GF.Grammar.CanonicalJSON
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Parser
+    GF.Grammar.PatternMatch
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.ShowTerm
+    GF.Grammar.Unify
+    GF.Grammar.Values
+    GF.Haskell
+    GF.Infra.BuildInfo
+    GF.Infra.CheckM
+    GF.Infra.Concurrency
+    GF.Infra.Dependencies
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.SIO
+    GF.Infra.UseIO
+    GF.Interactive
+    GF.JavaScript.AbsJS
+    GF.JavaScript.PrintJS
+    GF.Main
+    GF.Quiz
+    GF.Speech.CFGToFA
+    GF.Speech.FiniteState
+    GF.Speech.GSL
+    GF.Speech.JSGF
+    GF.Speech.PGFToCFG
+    GF.Speech.PrRegExp
+    GF.Speech.RegExp
+    GF.Speech.SISR
+    GF.Speech.SLF
+    GF.Speech.SRG
+    GF.Speech.SRGS_ABNF
+    GF.Speech.SRGS_XML
+    GF.Speech.VoiceXML
+    GF.Support
+    GF.System.Catch
+    GF.System.Concurrency
+    GF.System.Console
+    GF.System.Directory
+    GF.System.Process
+    GF.System.Signal
+    GF.Text.Clitics
+    GF.Text.Coding
+    GF.Text.Lexing
+    GF.Text.Pretty
+    GF.Text.Transliterations
+    LPGF
+    PGF
+    PGF.Binary
+    PGF.ByteCode
+    PGF.CId
+    PGF.Data
+    PGF.Expr
+    PGF.Expr
+    PGF.Forest
+    PGF.Generate
+    PGF.Internal
+    PGF.Linearize
+    PGF.Macros
+    PGF.Morphology
+    PGF.OldBinary
+    PGF.Optimize
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Printer
+    PGF.Probabilistic
+    PGF.Tree
+    PGF.TrieMap
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Utilities
+    PGF.VisualizeTree
+    PGF2
+    PGF2.Expr
+    PGF2.Type
+    PGF2.FFI
+    Paths_gf
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+
+  hs-source-dirs:
+    src/runtime/haskell-bind
+  other-modules:
+    PGF2
+    PGF2.FFI
+    PGF2.Expr
+    PGF2.Type
+  build-tools:     hsc2hs
+  extra-libraries: pgf gu
+  c-sources:       src/runtime/haskell-bind/utils.c
+  cc-options:      -std=c99
+
+  build-depends:
+    ansi-terminal,
+    array,
+    base>=4.6 && <5,
+    bytestring,
+    containers,
+    deepseq,
+    directory,
+    filepath,
+    ghc-prim,
+    hashable,
+    haskeline,
+    json,
+    mtl,
+    parallel>=3,
+    pretty,
+    process,
+    random,
+    terminfo,
+    text,
+    time,
+    transformers-compat,
+    unix,
+    unordered-containers,
+    utf8-string
+  default-language: Haskell2010

index.html

@@ -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,30 @@
     </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>PGF library API:<br>
-      <li><a href="doc/runtime-api.html">PGF library API (C runtime)</a></li>
+        <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>
+    <ul class="mb-2">
       <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>
       <li><a href="doc/gf-people.html">Authors</a></li>
-      <li><a href="http://school.grammaticalframework.org/2018/">Summer School</a></li>
+      <li><a href="//school.grammaticalframework.org/2020/">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>
@@ -148,9 +157,9 @@ least one, it may help you to get a first idea of what GF is.
     <h2>Applications & Availability</h2>
     <p>
     GF can be used for building
-    <a href="http://cloud.grammaticalframework.org/translator/">translation systems</a>,
+    <a href="//cloud.grammaticalframework.org/translator/">translation systems</a>,
-    <a href="http://cloud.grammaticalframework.org/minibar/minibar.html">multilingual web gadgets</a>,
+    <a href="//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="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 +174,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>
 
@@ -205,7 +215,10 @@ least one, it may help you to get a first idea of what GF is.
 
     <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>.
+    You can <a href="https://webchat.freenode.net/?channels=gf">open a web chat</a>
+    or <a href="/irc/">browse the channel logs</a>.
+    </p>
+    <p>
     If you have a larger question which the community may benefit from, we recommend you ask it on the <a href="http://groups.google.com/group/gf-dev">mailing list</a>.
     </p>
 
@@ -215,14 +228,22 @@ least one, it may help you to get a first idea of what GF is.
     <h2>News</h2>
 
     <dl class="row">
+      <dt class="col-sm-3 text-center text-nowrap">2021-03-01</dt>
+      <dd class="col-sm-9">
+        <a href="//school.grammaticalframework.org/2020/">Seventh GF Summer School</a>, in Singapore and online, 26 July &ndash; 8 August 2021.
+      </dd>
+      <dt class="col-sm-3 text-center text-nowrap">2020-09-29</dt>
+      <dd class="col-sm-9">
+        <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>
       <dt class="col-sm-3 text-center text-nowrap">2018-12-03</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
+        <a href="//school.grammaticalframework.org/2018/">Sixth GF Summer School</a> in Stellenbosch (South Africa), 3–14 December 2018
       </dd>
       <dt class="col-sm-3 text-center text-nowrap">2018-12-02</dt>
       <dd class="col-sm-9">
         <strong>GF 3.10 released.</strong>
-        <!-- <a href="download/release-3.10.html">Release notes</a> -->
+        <a href="download/release-3.10.html">Release notes</a>
       </dd>
       <dt class="col-sm-3 text-center text-nowrap">2018-07-25</dt>
       <dd class="col-sm-9">
@@ -241,7 +262,7 @@ least one, it may help you to get a first idea of what GF is.
         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="//school.grammaticalframework.org/2017/">GF Summer School</a> in Riga (Latvia), 14-25 August 2017
       </dd>
     </dl>
 
@@ -261,7 +282,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 +307,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>
@@ -317,9 +338,11 @@ least one, it may help you to get a first idea of what GF is.
     Afrikaans,
     Amharic (partial),
     Arabic (partial),
+    Basque (partial),
     Bulgarian,
     Catalan,
     Chinese,
+    Czech (partial),
     Danish,
     Dutch,
     English,
@@ -331,10 +354,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 +372,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 +396,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">
+<footer class="bg-light mt-5 py-4">
-  <div class="container mb-5">
+  <div class="container mb-3">
-    <div class="row">
+    <div class="text-center text-muted">
-    <div>
+      <img style="height:50px; filter: opacity(.5) grayscale(1);" class="mb-3" src="doc/Logos/gf0.svg" alt="GF Logo"><br>
-  <div>
+      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">

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

src/compiler/GF/Command/Commands.hs

@@ -34,6 +34,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 +45,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
 

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

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

src/compiler/GF/Compile.hs

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

src/compiler/GF/Compile/CheckGrammar.hs

@@ -34,14 +34,13 @@ import qualified GF.Compile.Compute.ConcreteNew as CN
 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,7 +71,7 @@ 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) | 
@@ -89,10 +88,10 @@ 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
@@ -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,26 +131,32 @@ 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)) _ _ _) -> 
                                         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
+       CncCat {} ->
-                             Ok _ -> return $ updateTree i js
+         case lookupOrigInfo gr (am,c) of
-                             _    -> do checkWarn ("category" <+> c <+> "is not in abstract")
+           Ok (_,AbsCat _) -> return $ Map.insert c info js
-                                        return js
+           {- -- This might be too pedantic:
-       _                -> return $ updateTree i js
+           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. 
@@ -265,7 +270,7 @@ 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

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

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

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

@@ -15,7 +15,7 @@ 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.Operations(Err,err,errIn,maybeErr,mapPairsM)
 import GF.Data.Utilities(mapFst,mapSnd)
 import GF.Infra.Option
 import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
@@ -291,9 +291,17 @@ glue env (v1,v2) = glu v1 v2
                                 vt v = case value2term loc (local env) v of
                                          Left i  -> Error ('#':show i)
                                          Right t -> t
-                            in error . render $
+                                originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
-                                         ppL loc (hang "unsupported token gluing:" 4
+                                                               (Glue (vt v1) (vt v2)))
-                                                        (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
@@ -318,7 +326,7 @@ strsFromValue t = case t of
     return [strTok (str2strings def) vars | 
               def  <- d0,
               vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
-                                                          vv <- combinations v0]
+                                                          vv <- sequence v0]
            ]
   VFV ts -> concat # mapM strsFromValue ts
   VStrs ts -> concat # mapM strsFromValue ts
@@ -546,7 +554,7 @@ value2term' stop loc xs v0 =
 linPattVars p =
     if null dups
     then return pvs
-    else fail.render $ hang "Pattern is not linear:" 4 (ppPatt Unqualified 0 p)
+    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

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -1,365 +1,351 @@
 -- | Translate concrete syntax to Haskell
 module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
-import Data.List(sort,sortBy)
+import Data.List(isPrefixOf,sort,sortOn)
-import Data.Function(on)
 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.Predef(cPredef,cInts)
-import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos)--,allParamValues
+--import GF.Compile.Compute.Predef(predef)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp)
+--import GF.Compile.Compute.Value(Predefined(..))
-import GF.Grammar.Lockfield(isLockLabel)
+import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
-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.Infra.Option
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Haskell as H
-import GF.Haskell
+import GF.Grammar.Canonical as C
-import Debug.Trace
+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)
+  [(filename,render80 $ concrete2haskell opts abstr cncmod)
-     | let cenv = resourceValues opts gr,
+     | let Grammar abstr cncs = grammar2canonical opts absname gr,
-       cnc<-allConcretes gr absname,
+       cncmod<-cncs,
-       let cncname = render cnc ++ ".hs" :: FilePath
+       let ModId name = concName cncmod
-           Ok cncmod = lookupModule gr cnc
+           filename = 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 =
+concrete2haskell opts
-    renderStyle style{lineLength=80,ribbonsPerLine=1} $
+                 abstr@(Abstract _ _ cats funs)
-      haskPreamble va absname cnc $$ vcat (
+                 modinfo@(Concrete cnc absname _ ps lcs lns) =
-      nl:Comment "--- Parameter types ---":
+  haskPreamble absname cnc $$
-      neededParamTypes S.empty (params defs) ++
+  vcat (
-      nl:Comment "--- Type signatures for linearization functions ---":
+    nl:Comment "--- Parameter types ---":
-      map signature (S.toList allcats)++
+    map paramDef ps ++
-      nl:Comment "--- Linearization functions for empty categories ---":
+    nl:Comment "--- Type signatures for linearization functions ---":
-      emptydefs ++
+    map signature cats ++
-      nl:Comment "--- Linearization types and linearization functions ---":
+    nl:Comment "--- Linearization functions for empty categories ---":
-      map ppDef defs ++
+    emptydefs ++
-      nl:Comment "--- Type classes for projection functions ---":
+    nl:Comment "--- Linearization types ---":
-      map labelClass (S.toList labels) ++
+    map lincatDef lcs ++
-      nl:Comment "--- Record types ---":
+    nl:Comment "--- Linearization functions ---":
-      concatMap recordType recs)
+    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 "s"
 
-    rhss = map (either snd (snd.snd)) defs
+    signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
-    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))
       where
         abs = tcon0 (prefixIdent "A." (gId c))
         lin = tcon0 lc
-        lf = prefixIdent "lin" c
+        lf = linfunName c
-        lc = prefixIdent "Lin" 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
+    emptyCats = allcats `S.difference` linfuncats
-    cats = S.fromList [c|Right (c,_)<-defs]
+      where
-    allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname]
+     --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
+       allcats = S.fromList [c | CatDef c _<-cats]
+      
+    gId :: ToIdent i => i -> Ident
+    gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
+          . toIdent
 
-    params = S.toList . S.unions . map params1
-    params1 (Left (_,rhs)) = paramTypes gr rhs
-    params1 (Right (_,(_,rhs))) = tableTypes gr [rhs]
-
-    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 [] = []
+    haskPreamble :: ModId -> ModId -> Doc
-    neededParamTypes have (q:qs) =
+    haskPreamble absname cncname =
-        if q `S.member` have
+      "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
-        then neededParamTypes have qs
+      "module" <+> cncname <+> "where" $$
-        else let ((got,need),def) = paramType va gId gr q
+      "import Prelude hiding (Ordering(..))" $$
-             in def++neededParamTypes (S.union got have) (S.toList need++qs)
+      "import Control.Applicative((<$>),(<*>))" $$
-
+      "import PGF.Haskell" $$
-haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc
+      "import qualified" <+> absname <+> "as A" $$
-haskPreamble va absname cncname =
+      "" $$
-  "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
+      "--- Standard definitions ---" $$
-  "module" <+> cncname <+> "where" $$
+      "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
-  "import Prelude hiding (Ordering(..))" $$
+      "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
-  "import Control.Applicative((<$>),(<*>))" $$
+      "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
-  "import PGF.Haskell" $$
+      "" $$
-  "import qualified" <+> absname <+> "as A" $$
+      "----------------------------------------------------" $$
-  "" $$
+      "-- Automatic translation from GF to Haskell follows" $$
-  "--- 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))]
       where
-        Ok abstype = lookupFunType gr absname name
+        pure = if va then brackets else pp
-        (absctx,_abscat,_absargs) = typeForm abstype
 
-        e' = unAbs (length params) $
+    paramDef pd =
-             nf loc (mkAbs params (mkApp def (map Vr args)))
+      case pd of
-        params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx]
+        ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
-        args = map snd params
+        ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
-        abs_args = map (prefixIdent "abs_") args
+          where
-        lhs = [ConP (aId name) (map VarP abs_args)]
+            paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
-        rhs = foldr letlin e' (zip args absctx)
+            derive = ["Eq","Ord","Show"]
-        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)
 
-    unAbs 0 t = t
+    convLinType = ppT
-    unAbs n (Abs _ _ t) = unAbs (n-1) t
+      where
-    unAbs _ t = t
+        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)
+class Records t where
-  where
+  records :: t -> S.Set [LabelId]
-    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 gr t =
+instance Records t => Records [t] where
-  case t of
+  records = S.unions . map records
-    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 = trace ("Ignore: "++show t) S.empty
+instance (Records t1,Records t2) => Records (t1,t2) where
-
+  records (t1,t2) = S.union (records t1) (records t2)
-
+
-
+instance Records LincatDef where
-records ts = S.unions (map recs ts)
+  records (LincatDef _ lt) = records lt
-  where
+
-    recs t =
+instance Records LinDef where
-      case t of
+  records (LinDef _ _ lv) = records lv
-        R r -> S.insert (labels r) (records (map (snd.snd) r))
+
-        RecType r -> S.insert (labels r) (records (map snd r))
+instance Records LinType where
-        _ -> collectOp recs t
+  records t =
-
+    case t of
-    labels = sort . filter (not . isLockLabel) . map fst
+      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)
+    (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
-    (_,FV ts) -> FV (map (coerce env ty) ts)
+    (TableType ti tv,TableValue _ cs) ->
-    (Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts)
+      TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
-    (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs)
+    (RecordType rt,RecordValue r) ->
-    (RecType rt,R r) ->
+      RecordValue [RecordRow l (coerce env ft f) |
-      R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
+                     RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
-    (RecType rt,Vr x)->
+    (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) $
+                            --trace ("coerce "++render ty'++" to "++render ty) $
-          App (to_rcon (map fst rt)) t
+                            app (to_rcon rt) [t]
-        _ -> trace ("no coerce to "++render ty) 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
+    app f ts = ParamConstant (Param f ts) -- !! a hack
-    extend env _ = env
+    to_rcon = ParamId . Unqual . to_rcon' . labels
 
-convert va gId gr = convert' va gId [] gr
+patVars p = []
 
-convert' va gId vs gr = ppT
+labels r = [l|RecordRow l _<-r]
-  where
-    ppT0 = convert' False gId vs gr
-    ppTv vs' = convert' va gId vs' gr
 
-    ppT t =
+proj = Var . identS . proj'
-      case t of
+proj' (LabelId l) = "proj_"++l
-         -- Only for 'let' inserted on the top-level by this converter:
+rcon = Var . rcon'
-        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
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
+rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
-to_rcon = con . to_rcon'
+
 to_rcon' = ("to_"++) . rcon_name
 
 recordType ls =
@@ -400,31 +386,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 +394,23 @@ enumCon name arity =
     ap (List [f]) a = Op f "<$>" a
     ap f a = Op f "<*>" a
 
-qual :: ModuleName -> Ident -> Ident
+lincatName,linfunName :: CatId -> Ident
-qual m = prefixIdent (render m++"_")
+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) = qIdentS q
+instance ToIdent PredefId where toIdent (PredefId s) = identS s
+instance ToIdent CatId   where toIdent (CatId s) = identS s
+instance ToIdent C.FunId where toIdent (FunId s) = identS s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
+
+qIdentS = identS . unqual
+
+unqual (Qual (ModId m) n) = m++"_"++n
+unqual (Unqual n) = n
+
+instance ToIdent VarId where
+  toIdent Anonymous = identW
+  toIdent (VarId s) = identS s

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

src/compiler/GF/Compile/GeneratePMCFG.hs

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

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -0,0 +1,390 @@
+-- | 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 qualified Data.Set as S
+import GF.Data.ErrM
+import GF.Text.Pretty
+import GF.Grammar.Grammar
+import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
+import GF.Grammar.Lockfield(isLockLabel)
+import GF.Grammar.Predef(cPredef,cInts)
+import GF.Compile.Compute.Predef(predef)
+import GF.Compile.Compute.Value(Predefined(..))
+import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
+import GF.Infra.Option(Options, optionsPGF)
+import PGF.Internal(Literal(..))
+import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Grammar.Canonical as C
+import Debug.Trace
+
+-- | Generate Canonical code for the named abstract syntax and all associated
+-- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> SourceGrammar -> 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 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 -- !!
+
+    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 opts absname gr =
+  [(cncname,concrete2canonical gr cenv absname cnc cncmod)
+     | let cenv = resourceValues opts gr,
+       cnc<-allConcretes gr absname,
+       let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
+           Ok cncmod = lookupModule gr cnc
+  ]
+
+-- | Generate Canonical GF for the given concrete module.
+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 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' = 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)
+--  aId n = prefixIdent "A." (gId n)
+
+    unAbs 0 t = t
+    unAbs n (Abs _ _ t) = unAbs (n-1) t
+    unAbs _ t = t
+
+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 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 = trace ("Ignore: "++show t) S.empty
+
+
+convert gr = convert' gr []
+
+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 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' "++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
+
+    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) -}
+      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 $ "pre "++show t
+
+        pat (PString s) = [s]
+        pat (PAlt p1 p2) = pat p1++pat p2
+        pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
+        pat p = error $ "pat "++show p
+
+    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 v1 v2 =
+  case (v1,v2) of
+    (LiteralValue (StrConstant ""),_) -> v2
+    (_,LiteralValue (StrConstant "")) -> v1
+    _ -> ConcatValue v1 v2
+
+-- | Smart constructor for projections
+projection r l = maybe (Projection r l) id (proj r l)
+
+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 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 = CommentedValue "impossible"
+
+mightMatchRow v (TableRow p _) =
+  case p of
+    WildPattern -> True
+    _ -> mightMatch v p
+
+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 (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
+        _ -> False
+    _ -> True
+
+patVars p =
+  case p of
+    PV x -> [x]
+    PAs x p -> x:patVars p
+    _ -> collectPattOp patVars p
+
+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 $ "Missing case in convType for: "++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 ("convSort "++show k)
+
+toParamType t = case convType t of
+                  ParamType pt -> pt
+                  _ -> error ("toParamType "++show t)
+
+toParamId t = case toParamType t of
+                   ParamTypeId p -> p
+
+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 = LabelId . render -- hmm
+modId (MN m) = ModId (showIdent m)
+
+class FromIdent i where gId :: Ident -> i
+
+instance FromIdent VarId where
+  gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
+
+instance FromIdent C.FunId where gId = C.FunId . showIdent
+instance FromIdent CatId where gId = CatId . showIdent
+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 m n = Qual (modId m) (showIdent n)
+unqual n = Unqual (showIdent n)
+
+convFlags gr mn =
+  Flags [(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

src/compiler/GF/Compile/GrammarToLPGF.hs

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

src/compiler/GF/Compile/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]

src/compiler/GF/Compile/Optimize.hs

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

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -26,50 +26,58 @@ import Data.List --(isPrefixOf, find, intersperse)
 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 (++++) [] $  
+grammar2haskell opts name gr = foldr (++++) [] $
-  pragmas ++ haskPreamble gadt name ++ [types, gfinstances gId lexical gr'] ++ compos
+  pragmas ++ haskPreamble gadt name derivingClause extraImports ++
+  [types, gfinstances gId lexical gr'] ++ compos
     where gr' = hSkeleton gr
           gadt = haskellOption opts HaskellGADT
+          dataExt = haskellOption opts HaskellData
           lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
-          gId | haskellOption opts HaskellNoPrefix = id
+          gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
-              | otherwise = ("G"++)
+              | otherwise = ("G"++) . rmForbiddenChars
-          pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}","{-# LANGUAGE GADTs #-}"]
+          -- 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 = []
           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 gadt name derivingClause extraImports =
  [
   "module " ++ name ++ " where",
   ""
- ] ++
+ ] ++ extraImports ++ [
- (if gadt then [
-  "import Control.Monad.Identity",
-  "import Data.Monoid"
-  ] else []) ++
- [
   "import PGF hiding (Tree)",
   "----------------------------------------------------",
   "-- 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 +85,11 @@ haskPreamble gadt name =
   ""
  ]
 
-predefInst gadt gtyp typ destr consr = 
+predefInst gadt derivingClause gtyp typ destr consr =
   (if gadt
-    then [] 
+    then []
-    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show\n\n") 
+    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
-    ) 
+    )
   ++
   "instance Gf" +++ gtyp +++ "where" ++++
   "  gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
@@ -94,24 +102,24 @@ type OIdent = String
 
 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 
-datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
+datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd
+datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
 
 gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
 gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
 
 
-hDatatype  :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
+hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
-hDatatype _ _ ("Cn",_) = "" ---
+hDatatype _ _ _ ("Cn",_) = "" ---
-hDatatype gId _ (cat,[]) = "data" +++ gId cat
+hDatatype gId _ _ (cat,[]) = "data" +++ gId cat
-hDatatype gId _ (cat,rules) | isListCat (cat,rules) = 
+hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) =
- "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" 
+ "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
-  +++ "deriving Show"
+  +++ derivingClause
-hDatatype gId lexical (cat,rules) =
+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 []

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

src/compiler/GF/Compile/Rename.hs

@@ -27,19 +27,20 @@ module GF.Compile.Rename (
 	       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.Grammar.Lookup
-import GF.Infra.CheckM
 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.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 +56,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
 
@@ -73,12 +74,12 @@ renameIdentTerm' env@(act,imps) t0 =
     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
@@ -93,30 +94,21 @@ renameIdentTerm' env@(act,imps) t0 =
       | otherwise     = checkError s
 
     ident alt c = 
-      case lookupTree showIdent c act of
+      case Map.lookup c act of
-        Ok f -> return (f c)
+        Just f -> return (f c)
-        _    -> case lookupTreeManyAll showIdent opens c of
+        _      -> case mapMaybe (Map.lookup c) opens of
-                  [f]  -> return (f c)
+                    [f]  -> return (f c)
-                  []   -> alt c ("constant not found:" <+> c $$
+                    []   -> alt c ("constant not found:" <+> c $$
-                                 "given" <+> fsep (punctuate ',' (map fst qualifs)))
+                                   "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                  fs   -> case nub [f c | f <- fs]  of
+                    fs   -> case nub [f c | f <- fs]  of
-                            [tr]     -> return tr
+                              [tr]     -> return tr
-{-
+                              ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
-                            ts       -> return $ AdHocOverload ts  
+                                                        "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
-                                        -- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014
+                                                        "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                                        -- the old definition is below and still presupposed in TypeCheck.Concrete
+                                             return t
--}
-                            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
 
-            -- a warning will be generated in CheckGrammar, and the head returned
+info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
-            -- in next V: 
+info2status mq c i = case i of
-            -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 
-
-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 +116,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))
+  OSimple i   -> Map.mapWithKey (info2status (Just i))
-  OQualif i j -> mapTree (info2status (Just j))
+  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,14 +128,14 @@ 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 :: ModuleName -> ModuleInfo -> StatusMap
-self2status c m = mapTree (info2status (Just c)) (jments m)
+self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
 
   
 renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
@@ -244,7 +236,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

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

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

@@ -127,8 +127,12 @@ inferLType gr g trm = case trm of
              ty <- if isWildIdent z 
                       then return val
                       else substituteLType [(bt,z,a')] val
-             return (App f' a',ty) 
+             return (App f' a',ty)
-           _ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty)
+           _ ->
+             let term = ppTerm Unqualified 0 f
+                 funName = pp . head . words .render $ term
+              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
+                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")
 
    S f x -> do
      (f', fty) <- inferLType gr g f
@@ -220,8 +224,14 @@ inferLType gr g trm = case trm of
      return (RecType (zip ls ts'), typeType)
 
    ExtR r s -> do
-     (r',rT) <- inferLType gr g r 
+   
+---     over <- getOverload gr g Nothing r
+---     let r1 = maybe r fst over
+     let r1 = r --- 
+
+     (r',rT) <- inferLType gr g r1
      rT'     <- computeLType gr g rT
+     
      (s',sT) <- inferLType gr g s
      sT'     <- computeLType gr g sT
 
@@ -327,7 +337,7 @@ getOverload gr g mt ot = case appForm ot of
        v <- matchOverload f typs ttys
        return $ Just v
      _ -> return Nothing
-
+     
  where
    collectOverloads tr@(Q c) = case lookupOverload gr c of 
      Ok typs -> typs
@@ -360,12 +370,13 @@ getOverload gr g mt ot = case appForm ot of
                       nest 2 (showTypes pre)
          return (mkApp fun tts, val)
        ([],[]) -> do
-         checkError $ "no overload instance of" <+> ppTerm Unqualified 0 f $$
+         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
-                      "for" $$
+                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
+                      "for argument list" $$
                       nest 2 stysError $$
-                      "among" $$
+                      "among alternatives" $$
-                      nest 2 (vcat stypsError) $$
+                      nest 2 (vcat stypsError) 
-                      maybe empty (\x -> "with value type" <+> ppType x) mt
+
 
        (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
          ([(val,fun)],_) -> do
@@ -394,7 +405,7 @@ getOverload gr g mt ot = case appForm ot of
    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
@@ -427,7 +438,9 @@ checkLType gr g trm typ0 = do
                        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
+        _ -> 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
@@ -505,8 +518,13 @@ checkLType gr g trm typ0 = do
                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])
+---         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)
@@ -637,9 +655,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 $ s <+> "type of" <+> ppTerm Unqualified 0 trm $$
+    False ->
-                          "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
+      let inferredType = ppTerm Qualified 0 u
-                          "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
+          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

src/compiler/GF/Compile/Update.hs

@@ -27,9 +27,10 @@ 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
@@ -101,16 +102,17 @@ 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 notInM0 c _  = all (not . Map.member c . jments) m0s
-                let js2 = filterBinTree notInM0 js'
+                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)
+      let stat' = if all (flip elem infs) is
-                    [i | i <- is, notElem i infs]
+                    then MSComplete
+                    else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete) 
              (checkError ("module" <+> i <+> "remains incomplete"))
       ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
@@ -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 js0 = Map.mapMaybeWithKey (\c j -> if isInherited incl c
-      let js1 = buildTree (tree2list js_ ++ js0)
+                                               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,14 +140,14 @@ 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)
+             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
+		                     Ok k  -> return $ Map.insert c k new
 		                     Bad _ -> do (base,j) <- case j of 
 		                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
 		                                               _          -> return (base,j)
@@ -155,8 +160,8 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
 		                                             nest 4 (ppJudgement Qualified (c,j)) $$
 		                                             "in module" <+> base)
                          Nothing-> if isCompl
-                                     then return $ updateTree (c,indirInfo name i) new
+                                     then return $ Map.insert c (indirInfo name i) new
-                                     else return $ updateTree (c,i) new
+                                     else return $ Map.insert c i new
       where
         i = globalizeLoc (msrc mi) i0
 

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"
+              }
+            ]
+          }
+        }
+      }
+    }
+  }
+}

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)

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

src/compiler/GF/Compiler.hs

@@ -1,30 +1,36 @@
-module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writePGF, writeLPGF, writeOutputs) where
 
 import PGF
 import PGF.Internal(concretes,optimizePGF,unionPGF)
 import PGF.Internal(putSplitAbs,encodeFile,runPut)
-import GF.Compile as S(batchCompile,link,srcAbsName)
+import LPGF(LPGF)
+import qualified LPGF
+import GF.Compile as S(batchCompile,link,linkl,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
-import GF.Grammar.CFG
+import GF.Grammar.CFG hiding (Grammar)
+import GF.Grammar.Grammar (Grammar, ModuleName)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
 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 Data.Time(UTCTime)
 import qualified Data.ByteString.Lazy as BSL
+import GF.Grammar.CanonicalJSON (encodeJSON)
 import System.FilePath
-import Control.Monad(when,unless,forM_)
+import Control.Monad(when,unless,forM,void)
 
 -- | Compile the given GF grammar files. The result is a number of @.gfo@ files
 -- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
@@ -45,9 +51,9 @@ mainGFC opts fs = do
    extensionIs ext = (== ext) .  takeExtension
 
 compileSourceFiles :: Options -> [FilePath] -> IOE ()
-compileSourceFiles opts fs = 
+compileSourceFiles opts fs =
     do output <- batchCompile opts fs
-       cncs2haskell output
+       exportCanonical output
        unless (flag optStopAfterPhase opts == Compile) $
            linkGrammars opts output
   where
@@ -55,15 +61,35 @@ compileSourceFiles opts fs =
     batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
                                return (t,[cnc_gr])
 
-    cncs2haskell output =
+    exportCanonical (_time, canonical) =
-      when (FmtHaskell `elem` flag optOutputFormats opts &&
+      do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
-            haskellOption opts HaskellConcrete) $
+           mapM_ cnc2haskell canonical
-        mapM_ cnc2haskell (snd output)
+         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
@@ -71,6 +97,10 @@ compileSourceFiles opts fs =
 -- If a @.pgf@ file by the same name already exists and it is newer than the
 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
 -- recreated. Calls 'writePGF' and 'writeOutputs'.
+linkGrammars :: Options -> (UTCTime,[(ModuleName, Grammar)]) -> IOE ()
+linkGrammars opts (_,cnc_grs) | FmtLPGF `elem` flag optOutputFormats opts = do
+  lpgf <- linkl opts (head cnc_grs)
+  void $ writeLPGF opts lpgf
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -80,7 +110,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,11 +147,13 @@ 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
-           else writePGF opts pgf
+           else void $ writePGF opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -129,33 +163,46 @@ unionPGFFiles opts fs =
 -- Calls 'exportPGF'.
 writeOutputs :: Options -> PGF -> IOE ()
 writeOutputs opts pgf = do
-  sequence_ [writeOutput opts name str 
+  sequence_ [writeOutput opts name str
                  | fmt <- flag optOutputFormats opts,
                    (name,str) <- exportPGF opts fmt pgf]
 
 -- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
 -- 'link') to a @.pgf@ file.
 -- A split PGF file is output if the @-split-pgf@ option is used.
-writePGF :: Options -> PGF -> IOE ()
+writePGF :: Options -> PGF -> IOE [FilePath]
 writePGF opts pgf =
     if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
   where
     writeNormalPGF =
        do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
           writing opts outfile $ encodeFile outfile pgf
+          return [outfile]
 
     writeSplitPGF =
       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
          writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
                                 --encodeFile_ outfile (putSplitAbs pgf)
-         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
+         outfiles <- forM (Map.toList (concretes pgf)) $ \cnc -> do
            let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
            writing opts outfile $ encodeFile outfile cnc
+           return outfile
 
+         return (outfile:outfiles)
 
-writeOutput :: Options -> FilePath-> String -> IOE ()
+writeLPGF :: Options -> LPGF -> IOE FilePath
-writeOutput opts file str = writing opts path $ writeUTF8File path str
+writeLPGF opts lpgf = do
-  where path = outputPath opts file
+  let
+    grammarName = fromMaybe (showCId (LPGF.abstractName lpgf)) (flag optName opts)
+    outfile = outputPath opts (grammarName <.> "lpgf")
+  writing opts outfile $ liftIO $ LPGF.encodeFile outfile lpgf
+  return outfile
+
+writeOutput :: Options -> FilePath-> String -> IOE FilePath
+writeOutput opts file str = do
+  let outfile = outputPath opts file
+  writing opts outfile $ writeUTF8File outfile str
+  return outfile
 
 -- * Useful helper functions
 

src/compiler/GF/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

src/compiler/GF/Data/BacktrackM.hs

@@ -13,6 +13,7 @@
 -----------------------------------------------------------------------------
 
 {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
 module GF.Data.BacktrackM (
                     -- * the backtracking state monad
 		    BacktrackM,
@@ -32,6 +33,7 @@ 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
@@ -69,6 +71,12 @@ 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
+
+#if !(MIN_VERSION_base(4,13,0))
+    fail = Fail.fail
+#endif
+
+instance Fail.MonadFail (BacktrackM s) where
     fail _ = mzero
 
 instance Functor (BacktrackM s) where

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)

src/compiler/GF/Data/IntMapBuilder.hs

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

src/compiler/GF/Data/Operations.hs

@@ -26,16 +26,8 @@ module GF.Data.Operations (
 		   -- ** Checking
 		   checkUnique, unifyMaybeBy, unifyMaybe,
 
-                   -- ** Monadic operations on lists and pairs
+           -- ** Monadic operations on lists and pairs
-		   mapPairListM, mapPairsM, pairM,
+		   mapPairsM, pairM,
-
-		   -- ** Binary search trees; now with FiniteMap
-		   BinTree, emptyBinTree, isInBinTree, --justLookupTree,
-		   lookupTree, --lookupTreeMany,
-                   lookupTreeManyAll, updateTree,
-		   buildTree, filterBinTree,
-                   mapTree, --mapMTree,
-                   tree2list,
  
 		   -- ** Printing
 		   indent, (+++), (++-), (++++), (+++-), (+++++),
@@ -47,13 +39,8 @@ module GF.Data.Operations (
 		   topoTest, topoTest2,
 
 		   -- ** Misc
-		   ifNull,
+		   readIntArg,
-		   combinations, done, readIntArg, --singleton,
 		   iterFix,  chunks,
-{-
-		   -- ** State monad with error; from Agda 6\/11\/2001
-		   STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
--}
                 
 		  ) where
 
@@ -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
@@ -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'
@@ -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
@@ -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"
--}
+-}

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
+
+-- | 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
+
+--------------------------------------------------------------------------------
+-- ** Concrete 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)
+newtype 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,Ord,Show)
+
+data VarId = Anonymous | VarId Id  deriving (Eq,Show)
+
+newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
+type FlagName = Id
+data FlagValue = Str String | Int Int | Flt Double deriving Show
+
+
+-- *** Identifiers
+
+type Id = String
+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 "_"
+      _ -> parens p
+
+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)

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -0,0 +1,293 @@
+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)
+
+
+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) = (lbl, showJSON val)
+
+  readJSON  obj = head <$> readJSONs obj
+  readJSONs obj = mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (RecordRow (LabelId lbl) value)
+
+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 (m++"."++n)
+  showJSON (Unqual n) = showJSON n
+
+  readJSON o = do qualid <- readJSON o
+                  let (mod, id) = span (/= '.') qualid
+                  return $ if null mod then Unqual id else Qual (ModId mod) id
+
+instance JSON Flags where
+  -- flags are encoded directly as JSON records (i.e., objects):
+  showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
+
+  readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (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

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

src/compiler/GF/Grammar/Lookup.hs

@@ -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
+  case Map.lookup c t of
-    Ok v  -> return v
+    Just v  -> return v
-    Bad _ -> raise ("unknown identifier" +++ showIdent c)
+    Nothing -> raise ("unknown identifier" +++ showIdent c)
 
 lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
 lookupIdentInfo mo i = lookupIdent i (jments mo)
@@ -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

src/compiler/GF/Grammar/Macros.hs

@@ -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.
 
@@ -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)
@@ -555,16 +555,12 @@ strsFromTerm t = case t of
     return [strTok (str2strings def) vars | 
               def  <- d0,
               vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
-                                                          vv <- combinations v0]
+                                                          vv <- sequence v0]
            ]
   FV 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
@@ -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 :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
 allDependencies ism b = 
-  [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list 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]

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 

src/compiler/GF/Grammar/PatternMatch.hs

@@ -73,14 +73,13 @@ 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
+      (PW, _) -> return [] -- optimization with wildcard
-      (PV x,  _) | isInConstantFormt -> return [(x,t)]
+      (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?
@@ -108,6 +107,10 @@ tryMatch (p,t) = do
             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
@@ -132,6 +135,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 +217,4 @@ isMatchingForms ps ts = all match (zip ps ts') where
   match _ = True
   ts' = map appForm ts
 
--}
+-}

src/compiler/GF/Grammar/Printer.hs

@@ -209,7 +209,7 @@ ppTerm q d (S x y)     = case x of
 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 (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)))

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

src/compiler/GF/Infra/CheckM.hs

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

src/compiler/GF/Infra/Option.hs

@@ -2,13 +2,13 @@ module GF.Infra.Option
     (
      -- ** Command line options
      -- *** Option types
-     Options, 
+     Options,
-     Flags(..), 
+     Flags(..),
-     Mode(..), Phase(..), Verbosity(..), 
+     Mode(..), Phase(..), Verbosity(..),
-     OutputFormat(..), 
+     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:",
@@ -86,10 +87,14 @@ data Verbosity = Quiet | Normal | Verbose | Debug
 data Phase = Preproc | Convert | Compile | Link
   deriving (Show,Eq,Ord)
 
-data OutputFormat = FmtPGFPretty
+data OutputFormat = FmtLPGF
-                  | FmtJavaScript 
+                  | FmtPGFPretty
-                  | FmtPython 
+                  | FmtCanonicalGF
-                  | FmtHaskell 
+                  | FmtCanonicalJson
+                  | FmtJavaScript
+                  | FmtJSON
+                  | FmtPython
+                  | FmtHaskell
                   | FmtJava
                   | FmtProlog
                   | FmtBNF
@@ -98,37 +103,37 @@ data OutputFormat = FmtPGFPretty
                   | FmtNoLR
                   | FmtSRGS_XML
                   | FmtSRGS_XML_NonRec
-                  | FmtSRGS_ABNF 
+                  | FmtSRGS_ABNF
                   | FmtSRGS_ABNF_NonRec
-                  | FmtJSGF 
+                  | FmtJSGF
-                  | FmtGSL 
+                  | 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 
+                  | CFGTopDownFilter
-                  | CFGBottomUpFilter 
+                  | CFGBottomUpFilter
                   | CFGStartCatOnly
                   | CFGMergeIdentical
                   | CFGRemoveCycles
   deriving (Show,Eq,Ord)
 
 data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
-                   | HaskellConcrete | HaskellVariants
+                   | HaskellConcrete | HaskellVariants | HaskellData
   deriving (Show,Eq,Ord)
 
 data Warning = WarnMissingLincat
@@ -192,7 +197,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 +209,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 +282,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 +302,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 +328,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), lpgf, json, js, pgf_pretty, prolog, python, ...", -- gar,
                   "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
                   "Abstract only: haskell, ..."]), -- prolog_abs,
-     Option [] ["sisr"] (ReqArg sisrFmt "FMT") 
+     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") 
+     Option [] ["haskell"] (ReqArg hsOption "OPTION")
-            ("Turn on an optional feature when generating Haskell data types. 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 +373,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 +448,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 +472,13 @@ outputFormats :: [(String,OutputFormat)]
 outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
-outputFormatsExpl = 
+outputFormatsExpl =
-    [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
+    [(("lpgf",         FmtLPGF),"Linearisation-only PGF"),
+     (("pgf_pretty",   FmtPGFPretty),"Human-readable PGF"),
+     (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
+     (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
      (("js",           FmtJavaScript),"JavaScript (whole grammar)"),
+     (("json",         FmtJSON),"JSON (whole grammar)"),
      (("python",       FmtPython),"Python (whole grammar)"),
      (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
      (("java",         FmtJava),"Java (abstract syntax)"),
@@ -496,11 +506,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 +518,7 @@ optimizationPackages =
     ]
 
 cfgTransformNames :: [(String, CFGTransform)]
-cfgTransformNames = 
+cfgTransformNames =
     [("nolr",         CFGNoLR),
      ("regular",      CFGRegular),
      ("topdown",      CFGTopDownFilter),
@@ -523,7 +533,8 @@ haskellOptionNames =
      ("gadt",     HaskellGADT),
      ("lexical",  HaskellLexical),
      ("concrete", HaskellConcrete),
-     ("variants", HaskellVariants)]
+     ("variants", HaskellVariants),
+     ("data",     HaskellData)]
 
 -- | This is for bacward compatibility. Since GHC 6.12 we
 -- started using the native Unicode support in GHC but it
@@ -540,7 +551,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 +559,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 :: Fail.MonadFail m => String -> m OutputFormat
-readOutputFormat s = 
+readOutputFormat s =
     maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
 
 -- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -561,7 +572,7 @@ splitInModuleSearchPath s = case break isPathSep s of
     isPathSep :: Char -> Bool
     isPathSep c = c == ':' || c == ';'
 
--- 
+--
 -- * Convenience functions for checking options
 --
 
@@ -583,7 +594,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 +625,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                      
+                      ma = maxBound `asTypeOf` mi
-                   in if i >= fromEnum mi && i <= fromEnum ma 
+                   in if i >= fromEnum mi && i <= fromEnum ma
                         then Just (toEnum i `asTypeOf` mi)
                         else Nothing
 

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

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

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,9 @@ import GF.Server(server)
 #endif
 
 import GF.Command.Messages(welcome)
+import GF.Infra.UseIO (Output)
+-- Provides an orphan instance of MonadFail for StateT in ghc versions < 8
+import Control.Monad.Trans.Instances ()
 
 -- | Run the GF Shell in quiet mode (@gf -run@).
 mainRunGFI :: Options -> [FilePath] -> IO ()
@@ -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)
+                  unwords $ "\nLanguages:" : map showCId (languages pgf1)
-           else done
+           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,7 +431,7 @@ 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
                 _   -> Nothing

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
@@ -167,7 +164,7 @@ execute1' s0 =
          continue
       where
         execute :: [String] -> ShellM ()
-        execute [] = done
+        execute [] = return ()
         execute (line:lines) = whenM (execute1' line) (execute lines)
 
     execute_history _   =
@@ -282,14 +279,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) $

src/compiler/GF/System/Directory.hs

@@ -8,13 +8,13 @@ import System.Directory as D
                doesDirectoryExist,doesFileExist,getModificationTime,
                getCurrentDirectory,getDirectoryContents,getPermissions,
                removeFile,renameFile)
-import Data.Time.Compat
+--import Data.Time.Compat
 
 canonicalizePath path = liftIO $ D.canonicalizePath path
 createDirectoryIfMissing b = liftIO . D.createDirectoryIfMissing b
 doesDirectoryExist path = liftIO $ D.doesDirectoryExist path
 doesFileExist path = liftIO $ D.doesFileExist path
-getModificationTime path = liftIO $ fmap toUTCTime (D.getModificationTime path)
+getModificationTime path = liftIO $ {-fmap toUTCTime-} (D.getModificationTime path)
 getDirectoryContents path = liftIO $ D.getDirectoryContents path
 
 getCurrentDirectory :: MonadIO io => io FilePath

src/compiler/GF/Text/Lexing.hs

@@ -1,5 +1,5 @@
 -- | Lexers and unlexers - they work on space-separated word strings
-module GF.Text.Lexing (stringOp,opInEnv) where
+module GF.Text.Lexing (stringOp,opInEnv,bindTok) where
 
 import GF.Text.Transliterations
 

src/compiler/GF/Text/Pretty.hs

@@ -20,6 +20,7 @@ instance Pretty a => Pretty [a] where
   ppList = fsep . map pp -- hmm
 
 render x = PP.render (pp x)
+render80 x = renderStyle style{lineLength=80,ribbonsPerLine=1} x
 renderStyle s x = PP.renderStyle s (pp x)
 
 infixl 5 $$,$+$

src/example-based/gf-exb.cabal

@@ -9,7 +9,7 @@ executable exb.fcgi
   main-is: exb-fcgi.hs
   Hs-source-dirs: . ../server ../compiler ../runtime/haskell
   other-modules: ExampleService ExampleDemo
-                 FastCGIUtils Cache GF.Compile.ToAPI
+                 CGIUtils Cache GF.Compile.ToAPI
                  -- and a lot more...
   ghc-options: -threaded
   if impl(ghc>=7.0)
@@ -17,7 +17,7 @@ executable exb.fcgi
 
   build-depends: base >=4.2 && <5, json, cgi, fastcgi, random,
                  containers, old-time, directory, bytestring, utf8-string,
-                 pretty, array, mtl, fst, filepath
+                 pretty, array, mtl, time, filepath
 
   if os(windows)
     ghc-options: -optl-mwindows

src/runtime/c/Makefile.am

@@ -1,7 +1,7 @@
-lib_LTLIBRARIES = libgu.la libpgf.la libsg.la
+lib_LTLIBRARIES = libgu.la libpgf.la
 
 pkgconfigdir = $(libdir)/pkgconfig
-pkgconfig_DATA = libgu.pc libpgf.pc libsg.pc
+pkgconfig_DATA = libgu.pc libpgf.pc
 
 configincludedir = $(libdir)/libgu/include
 
@@ -37,10 +37,6 @@ pgfinclude_HEADERS = \
 	pgf/pgf.h \
 	pgf/data.h
 
-sgincludedir=$(includedir)/sg
-sginclude_HEADERS = \
-	sg/sg.h
-
 libgu_la_SOURCES = \
 	gu/assert.c \
 	gu/bits.c \
@@ -68,6 +64,7 @@ libpgf_la_SOURCES = \
 	pgf/data.h \
 	pgf/expr.c \
 	pgf/expr.h \
+	pgf/scanner.c \
 	pgf/parser.c \
 	pgf/lookup.c \
 	pgf/jit.c \
@@ -91,12 +88,6 @@ libpgf_la_SOURCES = \
 libpgf_la_LDFLAGS = -no-undefined
 libpgf_la_LIBADD = libgu.la
 
-libsg_la_SOURCES = \
-	sg/sqlite3Btree.c \
-	sg/sg.c
-libsg_la_LDFLAGS = -no-undefined
-libsg_la_LIBADD = libgu.la libpgf.la
-
 bin_PROGRAMS =
 
 AUTOMAKE_OPTIONS = foreign subdir-objects dist-bzip2
@@ -104,5 +95,4 @@ ACLOCAL_AMFLAGS = -I m4
 
 EXTRA_DIST = \
 	libgu.pc.in \
-	libpgf.pc.in \
+	libpgf.pc.in
-	libsg.pc.in

src/runtime/c/configure.ac

@@ -58,7 +58,6 @@ AC_CONFIG_LINKS(pgf/lightning/asm.h:$cpu_dir/asm.h			dnl
 AC_CONFIG_FILES([Makefile
 	         libgu.pc
 		 libpgf.pc
-		 libsg.pc
 		 ])
 
 AC_OUTPUT

src/runtime/c/gu/defs.h

@@ -74,6 +74,8 @@
 
 #ifdef GU_ALIGNOF
 # define gu_alignof GU_ALIGNOF
+#elif defined(_MSC_VER)
+# define gu_alignof __alignof
 #else
 # define gu_alignof(t_) \
 	((size_t)(offsetof(struct { char c_; t_ e_; }, e_)))
@@ -87,7 +89,7 @@
 
 #define GU_COMMA ,
 
-#define GU_ARRAY_LEN(t,a) (sizeof((const t[])a) / sizeof(t))
+#define GU_ARRAY_LEN(a) (sizeof(a) / sizeof(a[0]))
 
 #define GU_ID(...) __VA_ARGS__
 
@@ -193,9 +195,13 @@ typedef union {
 	void (*fp)();
 } GuMaxAlign;
 
+#if defined(_MSC_VER)
+#include <malloc.h>
+#define gu_alloca(N) alloca(N)
+#else
 #define gu_alloca(N)				\
 	(((union { GuMaxAlign align_; uint8_t buf_[N]; }){{0}}).buf_)
-
+#endif
 
 // For Doxygen
 #define GU_PRIVATE /** @private */

src/runtime/c/gu/map.c

@@ -7,6 +7,9 @@
 
 typedef struct GuMapData GuMapData;
 
+#define SKIP_DELETED 1
+#define SKIP_NONE    2
+
 struct GuMapData {
 	uint8_t* keys;
 	uint8_t* values;
@@ -19,6 +22,7 @@ struct GuMap {
 	GuHasher* hasher;
 	size_t key_size;
 	size_t value_size;
+	size_t cell_size;   // cell_size = GU_MAX(value_size,sizeof(uint8_t))
 	const void* default_value;
 	GuMapData data;
 	
@@ -30,9 +34,7 @@ gu_map_finalize(GuFinalizer* fin)
 {
 	GuMap* map = gu_container(fin, GuMap, fin);
 	gu_mem_buf_free(map->data.keys);
-	if (map->value_size) {
+	gu_mem_buf_free(map->data.values);
-		gu_mem_buf_free(map->data.values);
-	}
 }
 
 static const GuWord gu_map_empty_key = 0;
@@ -68,7 +70,7 @@ gu_map_entry_is_free(GuMap* map, GuMapData* data, size_t idx)
 }
 
 static bool
-gu_map_lookup(GuMap* map, const void* key, size_t* idx_out)
+gu_map_lookup(GuMap* map, const void* key, uint8_t del, size_t* idx_out)
 {
 	size_t n = map->data.n_entries;
 	if (map->hasher == gu_addr_hasher) {
@@ -78,13 +80,17 @@ gu_map_lookup(GuMap* map, const void* key, size_t* idx_out)
 		while (true) {
 			const void* entry_key =
 				((const void**)map->data.keys)[idx];
+
 			if (entry_key == NULL && map->data.zero_idx != idx) {
-				*idx_out = idx;
+				if (map->data.values[idx * map->cell_size] != del) { //skip deleted
-				return false;
+					*idx_out = idx;
+					return false;
+				}
 			} else if (entry_key == key) {
 				*idx_out = idx;
 				return true;
 			}
+
 			idx = (idx + offset) % n;
 		}
 	} else if (map->hasher == gu_word_hasher) {
@@ -156,33 +162,18 @@ gu_map_resize(GuMap* map, size_t req_entries)
 	size_t key_size = map->key_size;
 	size_t key_alloc = 0;
 	data->keys = gu_mem_buf_alloc(req_entries * key_size, &key_alloc);
+	memset(data->keys, 0, key_alloc);
 
-	size_t value_size = map->value_size;
 	size_t value_alloc = 0;
-	if (value_size) {
+	size_t cell_size = map->cell_size;
-		data->values = gu_mem_buf_alloc(req_entries * value_size,
+	data->values = gu_mem_buf_alloc(req_entries * cell_size, &value_alloc);
-						    &value_alloc);
+	memset(data->values, 0, value_alloc);
-		memset(data->values, 0, value_alloc);
-	}
-	
-	data->n_entries = gu_twin_prime_inf(value_size ?
-					    GU_MIN(key_alloc / key_size,
-						   value_alloc / value_size)
-					    : key_alloc / key_size);
-	if (map->hasher == gu_addr_hasher) {
-		for (size_t i = 0; i < data->n_entries; i++) {
-			((const void**)data->keys)[i] = NULL;
-		}
-	} else if (map->hasher == gu_string_hasher) {
-		for (size_t i = 0; i < data->n_entries; i++) {
-			((GuString*)data->keys)[i] = NULL;
-		}
-	} else {
-		memset(data->keys, 0, key_alloc);
-	}
 
+	data->n_entries = gu_twin_prime_inf(
+	                    GU_MIN(key_alloc / key_size,
+	                           value_alloc / cell_size));
 	gu_assert(data->n_entries > data->n_occupied);
-	
+
 	data->n_occupied = 0;
 	data->zero_idx = SIZE_MAX;
 
@@ -196,16 +187,14 @@ gu_map_resize(GuMap* map, size_t req_entries)
 		} else if (map->hasher == gu_string_hasher) {
 			old_key = (void*) *(GuString*)old_key;
 		}
-		void* old_value = &old_data.values[i * value_size];
+		void* old_value = &old_data.values[i * cell_size];
 
 		memcpy(gu_map_insert(map, old_key),
 		       old_value, map->value_size);
 	}
 
 	gu_mem_buf_free(old_data.keys);
-	if (value_size) {
+	gu_mem_buf_free(old_data.values);
-		gu_mem_buf_free(old_data.values);
-	}
 }
 
 
@@ -226,9 +215,9 @@ GU_API void*
 gu_map_find(GuMap* map, const void* key)
 {
 	size_t idx;
-	bool found = gu_map_lookup(map, key, &idx);
+	bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
 	if (found) {
-		return &map->data.values[idx * map->value_size];
+		return &map->data.values[idx * map->cell_size];
 	}
 	return NULL;
 }
@@ -244,7 +233,7 @@ GU_API const void*
 gu_map_find_key(GuMap* map, const void* key)
 {
 	size_t idx;
-	bool found = gu_map_lookup(map, key, &idx);
+	bool found = gu_map_lookup(map, key, SKIP_DELETED, &idx);
 	if (found) {
 		return &map->data.keys[idx * map->key_size];
 	}
@@ -255,17 +244,17 @@ GU_API bool
 gu_map_has(GuMap* ht, const void* key)
 {
 	size_t idx;
-	return gu_map_lookup(ht, key, &idx);
+	return gu_map_lookup(ht, key, SKIP_DELETED, &idx);
 }
 
 GU_API void*
 gu_map_insert(GuMap* map, const void* key)
 {
 	size_t idx;
-	bool found = gu_map_lookup(map, key, &idx);
+	bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
 	if (!found) {
 		if (gu_map_maybe_resize(map)) {
-			found = gu_map_lookup(map, key, &idx);
+			found = gu_map_lookup(map, key, SKIP_NONE, &idx);
 			gu_assert(!found);
 		}
 		if (map->hasher == gu_addr_hasher) {
@@ -277,7 +266,7 @@ gu_map_insert(GuMap* map, const void* key)
 			       key, map->key_size);
 		}
 		if (map->default_value) {
-			memcpy(&map->data.values[idx * map->value_size],
+			memcpy(&map->data.values[idx * map->cell_size],
 			       map->default_value, map->value_size);
 		}
 		if (gu_map_entry_is_free(map, &map->data, idx)) {
@@ -286,7 +275,32 @@ gu_map_insert(GuMap* map, const void* key)
 		}
 		map->data.n_occupied++;
 	}
-	return &map->data.values[idx * map->value_size];
+	return &map->data.values[idx * map->cell_size];
+}
+
+GU_API void
+gu_map_delete(GuMap* map, const void* key)
+{
+	size_t idx;
+	bool found = gu_map_lookup(map, key, SKIP_NONE, &idx);
+	if (found) {
+		if (map->hasher == gu_addr_hasher) {
+			((const void**)map->data.keys)[idx] = NULL;
+		} else if (map->hasher == gu_string_hasher) {
+			((GuString*)map->data.keys)[idx] = NULL;
+		} else {
+			memset(&map->data.keys[idx * map->key_size],
+			       0, map->key_size);
+		}
+		map->data.values[idx * map->cell_size] = SKIP_DELETED;
+
+		if (gu_map_buf_is_zero(&map->data.keys[idx * map->key_size],
+		                       map->key_size)) {
+			map->data.zero_idx = SIZE_MAX;
+		}
+
+		map->data.n_occupied--;
+	}
 }
 
 GU_API void
@@ -297,7 +311,7 @@ gu_map_iter(GuMap* map, GuMapItor* itor, GuExn* err)
 			continue;
 		}
 		const void* key = &map->data.keys[i * map->key_size];
-		void* value = &map->data.values[i * map->value_size];
+		void* value = &map->data.values[i * map->cell_size];
 		if (map->hasher == gu_addr_hasher) {
 			key = *(const void* const*) key;
 		} else if (map->hasher == gu_string_hasher) {
@@ -307,47 +321,33 @@ gu_map_iter(GuMap* map, GuMapItor* itor, GuExn* err)
 	}
 }
 
-typedef struct {
+GU_API bool
-	GuEnum en;
+gu_map_next(GuMap* map, size_t* pi, void* pkey, void* pvalue)
-	GuMap* ht;
-	size_t i;
-	GuMapKeyValue x;
-} GuMapEnum;
-
-static void
-gu_map_enum_next(GuEnum* self, void* to, GuPool* pool)
 {
-	*((GuMapKeyValue**) to) = NULL;
+	while (*pi < map->data.n_entries) {
-
+		if (gu_map_entry_is_free(map, &map->data, *pi)) {
-	size_t i;
+			(*pi)++;
-	GuMapEnum* en = (GuMapEnum*) self;
-	for (i = en->i; i < en->ht->data.n_entries; i++) {
-		if (gu_map_entry_is_free(en->ht, &en->ht->data, i)) {
 			continue;
 		}
-		en->x.key   = &en->ht->data.keys[i * en->ht->key_size];
-		en->x.value = &en->ht->data.values[i * en->ht->value_size];
-		if (en->ht->hasher == gu_addr_hasher) {
-			en->x.key = *(const void* const*) en->x.key;
-		} else if (en->ht->hasher == gu_string_hasher) {
-			en->x.key = *(GuString*) en->x.key;
-		}
 
-		*((GuMapKeyValue**) to) = &en->x;
+		if (map->hasher == gu_addr_hasher) {
-		break;
+            *((void**) pkey) = *((void**) &map->data.keys[*pi * sizeof(void*)]);
+        } else if (map->hasher == gu_word_hasher) {
+            *((GuWord*) pkey) = *((GuWord*) &map->data.keys[*pi * sizeof(GuWord)]);
+		} else if (map->hasher == gu_string_hasher) {
+			*((GuString*) pkey) = *((GuString*) &map->data.keys[*pi * sizeof(GuString)]);
+		} else {
+            memcpy(pkey, &map->data.keys[*pi * map->key_size], map->key_size);
+        }
+
+		memcpy(pvalue, &map->data.values[*pi * map->cell_size],
+		       map->value_size);
+
+		(*pi)++;
+		return true;
 	}
-	
-	en->i = i+1;
-}
 
-GU_API GuEnum*
+	return false;
-gu_map_enum(GuMap* ht, GuPool* pool)
-{
-	GuMapEnum* en = gu_new(GuMapEnum, pool);
-	en->en.next = gu_map_enum_next;
-	en->ht = ht;
-	en->i  = 0;
-	return &en->en;
 }
 
 GU_API size_t
@@ -363,8 +363,6 @@ gu_map_count(GuMap* map)
 	return count;
 }
 
-static const uint8_t gu_map_no_values[1] = { 0 };
-
 GU_API GuMap*
 gu_make_map(size_t key_size, GuHasher* hasher,
 	    size_t value_size, const void* default_value,
@@ -375,7 +373,7 @@ gu_make_map(size_t key_size, GuHasher* hasher,
 		.n_occupied = 0,
 		.n_entries = 0,
 		.keys = NULL,
-		.values = value_size ? NULL : (uint8_t*) gu_map_no_values,
+		.values = NULL,
 		.zero_idx = SIZE_MAX
 	};
 	GuMap* map = gu_new(GuMap, pool);
@@ -384,6 +382,7 @@ gu_make_map(size_t key_size, GuHasher* hasher,
 	map->data = data;
 	map->key_size = key_size;
 	map->value_size = value_size;
+	map->cell_size = GU_MAX(value_size,sizeof(uint8_t));
 	map->fin.fn = gu_map_finalize;
 	gu_pool_finally(pool, &map->fin);
 

src/runtime/c/gu/map.h

@@ -62,6 +62,9 @@ gu_map_has(GuMap* ht, const void* key);
 GU_API_DECL void*
 gu_map_insert(GuMap* ht, const void* key);
 
+GU_API_DECL void
+gu_map_delete(GuMap* ht, const void* key);
+
 #define gu_map_put(MAP, KEYP, V, VAL)				\
 	GU_BEGIN						\
 	V* gu_map_put_p_ = gu_map_insert((MAP), (KEYP));	\
@@ -71,13 +74,8 @@ gu_map_insert(GuMap* ht, const void* key);
 GU_API_DECL void
 gu_map_iter(GuMap* ht, GuMapItor* itor, GuExn* err);
 
-typedef struct {
+GU_API bool
-	const void* key;
+gu_map_next(GuMap* map, size_t* pi, void* pkey, void* pvalue);
-	void* value;
-} GuMapKeyValue;
-
-GU_API_DECL GuEnum*
-gu_map_enum(GuMap* ht, GuPool* pool);
 
 typedef GuMap GuIntMap;
 

src/runtime/c/gu/mem.c

@@ -8,6 +8,10 @@
 #include <sys/mman.h>
 #include <sys/stat.h>
 #endif
+#if defined(__MINGW32__) || defined(_MSC_VER)
+#include <malloc.h>
+#endif
+
 #if !defined(_MSC_VER)
 #include <unistd.h>
 #endif
@@ -108,6 +112,39 @@ gu_mem_buf_alloc(size_t min_size, size_t* real_size_out)
 	return gu_mem_buf_realloc(NULL, min_size, real_size_out);
 }
 
+#if defined(__MINGW32__) || defined(_MSC_VER)
+#include <windows.h>
+
+static int
+getpagesize()
+{
+  SYSTEM_INFO system_info;
+  GetSystemInfo(&system_info);
+  return system_info.dwPageSize;
+}
+#endif
+
+GU_API void*
+gu_mem_page_alloc(size_t min_size, size_t* real_size_out)
+{
+	size_t page_size = getpagesize();
+	size_t size = ((min_size + page_size - 1) / page_size) * page_size;
+	void *page = NULL;
+
+#if defined(ANDROID)
+	if ((page = memalign(page_size, size)) == NULL) {	
+#elif defined(__MINGW32__) || defined(_MSC_VER)
+	if ((page = malloc(size)) == NULL) {
+#else
+	if (posix_memalign(&page, page_size, size) != 0) {
+#endif
+		gu_fatal("Memory allocation failed");
+	}
+
+	*real_size_out = size;
+	return page;
+}
+
 GU_API void
 gu_mem_buf_free(void* buf)
 {
@@ -132,6 +169,7 @@ struct GuFinalizerNode {
 enum GuPoolType {
 	GU_POOL_HEAP,
 	GU_POOL_LOCAL,
+	GU_POOL_PAGE,
 	GU_POOL_MMAP
 };
 
@@ -180,6 +218,16 @@ gu_new_pool(void)
 	return pool;
 }
 
+GU_API GuPool*
+gu_new_page_pool(void)
+{
+	size_t sz = GU_FLEX_SIZE(GuPool, init_buf, gu_mem_pool_initial_size);
+	uint8_t* buf = gu_mem_page_alloc(sz, &sz);
+	GuPool* pool = gu_init_pool(buf, sz);
+	pool->type = GU_POOL_PAGE;
+	return pool;
+}
+
 GU_API GuPool* 
 gu_mmap_pool(char* fpath, void* addr, size_t size, void**pptr)
 {
@@ -238,7 +286,10 @@ gu_pool_expand(GuPool* pool, size_t req)
 					     gu_mem_chunk_max_size));
 	gu_assert(real_req >= sizeof(GuMemChunk));
 	size_t size = 0;
-	GuMemChunk* chunk = gu_mem_buf_alloc(real_req, &size);
+	GuMemChunk* chunk = 
+		(pool->type == GU_POOL_PAGE)
+		   ? gu_mem_page_alloc(real_req,  &size)
+		   : gu_mem_buf_alloc(real_req, &size);
 	chunk->next = pool->chunks;
 	pool->chunks = chunk;
 	pool->curr_buf = (uint8_t*) chunk;
@@ -309,6 +360,7 @@ gu_malloc_prefixed(GuPool* pool, size_t pre_align, size_t pre_size,
 	size_t full_size = gu_mem_advance(offsetof(GuMemChunk, data),
 					  pre_align, pre_size, align, size);
 	if (full_size > gu_mem_max_shared_alloc &&
+	    pool->type != GU_POOL_PAGE &&
 	    pool->type != GU_POOL_MMAP) {
 		GuMemChunk* chunk = gu_mem_alloc(full_size);
 		chunk->next = pool->chunks;

src/runtime/c/gu/mem.h

@@ -55,6 +55,11 @@ gu_local_pool_(uint8_t* init_buf, size_t sz);
  * should not be used in the bodies of recursive functions.
  */
 
+/// Create a pool where each chunk is corresponds to one or
+/// more pages.
+GU_API_DECL GuPool*
+gu_new_page_pool(void);
+
 /// Create a pool stored in a memory mapped file.
 GU_API_DECL GuPool* 
 gu_mmap_pool(char* fpath, void* addr, size_t size, void**pptr);
@@ -198,6 +203,9 @@ gu_mem_buf_realloc(
 	size_t min_size,
 	size_t* real_size_out);
 
+/// Allocate enough memory pages to contain min_size bytes.
+GU_API_DECL void*
+gu_mem_page_alloc(size_t min_size, size_t* real_size_out);
 
 /// Free a memory buffer.
 GU_API_DECL void

src/runtime/c/gu/seq.c

@@ -100,6 +100,11 @@ gu_seq_free(GuSeq* seq)
 	gu_mem_buf_free(seq);
 }
 
+static void
+gu_dummy_finalizer(GuFinalizer* self)
+{
+}
+
 GU_API void
 gu_buf_require(GuBuf* buf, size_t req_len)
 {
@@ -109,7 +114,9 @@ gu_buf_require(GuBuf* buf, size_t req_len)
 
 	size_t req_size = sizeof(GuSeq) + buf->elem_size * req_len;
 	size_t real_size;
-	
+
+	gu_require(buf->fin.fn != gu_dummy_finalizer);
+
 	if (buf->seq == NULL || buf->seq == gu_empty_seq())  {
 		buf->seq = gu_mem_buf_alloc(req_size, &real_size);
 		buf->seq->len = 0;
@@ -164,6 +171,24 @@ gu_buf_freeze(GuBuf* buf, GuPool* pool)
 	return seq;
 }
 
+GU_API void
+gu_buf_evacuate(GuBuf* buf, GuPool* pool)
+{
+	if (buf->seq != gu_empty_seq()) {
+		size_t len = gu_buf_length(buf);
+
+		GuSeq* seq = gu_make_seq(buf->elem_size, len, pool);
+		void* bufdata = gu_buf_data(buf);
+		void* seqdata = gu_seq_data(seq);
+		memcpy(seqdata, bufdata, buf->elem_size * len);
+		gu_mem_buf_free(buf->seq);
+
+		buf->seq       = seq;
+		buf->fin.fn    = gu_dummy_finalizer;
+		buf->avail_len = len;
+	}
+}
+
 GU_API void*
 gu_buf_insert(GuBuf* buf, size_t index)
 {
@@ -335,13 +360,8 @@ GU_API void
 gu_buf_heap_pop(GuBuf *buf, GuOrder *order, void* data_out)
 {
 	const void* last = gu_buf_trim(buf); // raises an error if empty
-
+	memcpy(data_out, buf->seq->data, buf->elem_size);
-	if (gu_buf_length(buf) > 0) {
+	gu_heap_siftup(buf, order, last, 0);
-		memcpy(data_out, buf->seq->data, buf->elem_size);
-		gu_heap_siftup(buf, order, last, 0);
-	} else {
-		memcpy(data_out, last, buf->elem_size);
-	}
 }
 
 GU_API void

src/runtime/c/gu/seq.h

@@ -182,6 +182,9 @@ gu_buf_heapify(GuBuf *buf, GuOrder *order);
 
 GU_API_DECL GuSeq*
 gu_buf_freeze(GuBuf* buf, GuPool* pool);
+
+GU_API_DECL void
+gu_buf_evacuate(GuBuf* buf, GuPool* pool);
 #endif // GU_SEQ_H_
 
 #ifdef GU_STRING_H_

src/runtime/c/pgf/aligner.c

@@ -142,14 +142,14 @@ pgf_aligner_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok)
 }
 
 static void
-pgf_aligner_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun)
+pgf_aligner_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, GuString ann, PgfCId fun)
 {
 	PgfAlignerLin* alin = gu_container(funcs, PgfAlignerLin, funcs);
 	gu_buf_push(alin->parent_stack, int, fid);
 }
 
 static void
-pgf_aligner_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun)
+pgf_aligner_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, GuString ann, PgfCId fun)
 {
 	PgfAlignerLin* alin = gu_container(funcs, PgfAlignerLin, funcs);
 	gu_buf_pop(alin->parent_stack, int);

src/runtime/c/pgf/data.h

@@ -322,7 +322,8 @@ typedef struct PgfProductionCoerce
 
 typedef struct {
 	PgfExprProb *ep;
-    GuSeq* lins;
+   	size_t n_lins;
+	PgfSymbols* lins[];
 } PgfProductionExtern;
 
 typedef struct {
@@ -344,8 +345,9 @@ struct PgfCCat {
 	PgfCncFuns* linrefs;
 	size_t n_synprods;
 	PgfProductionSeq* prods;
-	float viterbi_prob;
+	prob_t viterbi_prob;
 	int fid;
+	int chunk_count;
 	PgfItemConts* conts;
 	struct PgfAnswers* answers;
 	GuFinalizer fin[0];

src/runtime/c/pgf/expr.c

@@ -918,94 +918,6 @@ pgf_read_expr(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err)
 	return expr;
 }
 
-PGF_API int
-pgf_read_expr_tuple(GuIn* in,
-                    size_t n_exprs, PgfExpr exprs[],
-                    GuPool* pool, GuExn* err)
-{
-	GuPool* tmp_pool = gu_new_pool();
-	PgfExprParser* parser =
-		pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err);
-	if (parser->token_tag != PGF_TOKEN_LTRIANGLE)
-		goto fail;
-	pgf_expr_parser_token(parser, false);
-	for (size_t i = 0; i < n_exprs; i++) {
-		if (i > 0) {
-			if (parser->token_tag != PGF_TOKEN_COMMA)
-				goto fail;
-			pgf_expr_parser_token(parser, false);
-		}
-
-		exprs[i] = pgf_expr_parser_expr(parser, false);
-		if (gu_variant_is_null(exprs[i]))
-			goto fail;
-	}
-	if (parser->token_tag != PGF_TOKEN_RTRIANGLE)
-		goto fail;
-	pgf_expr_parser_token(parser, false);
-	if (parser->token_tag != PGF_TOKEN_EOF)
-		goto fail;
-	gu_pool_free(tmp_pool);
-
-	return 1;
-	
-fail:
-	gu_pool_free(tmp_pool);
-	return 0;
-}
-
-PGF_API GuSeq*
-pgf_read_expr_matrix(GuIn* in,
-                     size_t n_exprs,
-                     GuPool* pool, GuExn* err)
-{
-	GuPool* tmp_pool = gu_new_pool();
-	PgfExprParser* parser =
-		pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err);
-	if (parser->token_tag != PGF_TOKEN_LTRIANGLE)
-		goto fail;
-	pgf_expr_parser_token(parser, false);
-
-	GuBuf* buf = gu_new_buf(PgfExpr, pool);
-	
-	if (parser->token_tag != PGF_TOKEN_RTRIANGLE) {	
-		for (;;) {
-			PgfExpr* exprs = gu_buf_extend_n(buf, n_exprs);
-
-			for (size_t i = 0; i < n_exprs; i++) {
-				if (i > 0) {
-					if (parser->token_tag != PGF_TOKEN_COMMA)
-						goto fail;
-					pgf_expr_parser_token(parser, false);
-				}
-
-				exprs[i] = pgf_expr_parser_expr(parser, false);
-				if (gu_variant_is_null(exprs[i]))
-					goto fail;
-			}
-
-			if (parser->token_tag != PGF_TOKEN_SEMI)
-				break;
-
-			pgf_expr_parser_token(parser, false);
-		}
-
-		if (parser->token_tag != PGF_TOKEN_RTRIANGLE)
-			goto fail;
-	}
-
-	pgf_expr_parser_token(parser, false);
-	if (parser->token_tag != PGF_TOKEN_EOF)
-		goto fail;
-	gu_pool_free(tmp_pool);
-
-	return gu_buf_data_seq(buf);
-
-fail:
-	gu_pool_free(tmp_pool);
-	return NULL;
-}
-
 PGF_API PgfType*
 pgf_read_type(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err)
 {
@@ -1723,19 +1635,6 @@ pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
 	}
 }
 
-PGF_API void
-pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
-                     GuOut* out, GuExn* err)
-{
-	gu_putc('<', out, err);
-	for (size_t i = 0; i < n_exprs; i++) {
-		if (i > 0)
-			gu_putc(',', out, err);
-		pgf_print_expr(exprs[i], ctxt, 0, out, err);
-	}
-	gu_putc('>', out, err);
-}
-
 PGF_API bool
 pgf_type_eq(PgfType* t1, PgfType* t2)
 {
@@ -1771,6 +1670,168 @@ pgf_type_eq(PgfType* t1, PgfType* t2)
 	return true;
 }
 
+PGF_API PgfLiteral
+pgf_clone_literal(PgfLiteral lit, GuPool* pool)
+{
+	PgfLiteral new_lit = gu_null_variant;
+
+	GuVariantInfo inf = gu_variant_open(lit);
+	switch (inf.tag) {
+	case PGF_LITERAL_STR: {
+		PgfLiteralStr* lit_str     = inf.data;
+		PgfLiteralStr* new_lit_str =
+			gu_new_flex_variant(PGF_LITERAL_STR,
+						        PgfLiteralStr,
+						        val, strlen(lit_str->val)+1,
+						        &new_lit, pool);
+		strcpy(new_lit_str->val, lit_str->val);
+		break;
+	}
+	case PGF_LITERAL_INT: {
+		PgfLiteralInt *lit_int     = inf.data;
+		PgfLiteralInt *new_lit_int =
+			gu_new_variant(PGF_LITERAL_INT,
+						   PgfLiteralInt,
+						   &new_lit, pool);
+		new_lit_int->val = lit_int->val;
+		break;
+	}
+	case PGF_LITERAL_FLT: {
+		PgfLiteralFlt *lit_flt     = inf.data;
+		PgfLiteralFlt *new_lit_flt =
+			gu_new_variant(PGF_LITERAL_FLT,
+						   PgfLiteralFlt,
+						   &new_lit, pool);
+		new_lit_flt->val = lit_flt->val;
+		break;
+	}
+	default:
+		gu_impossible();
+	}
+
+	return new_lit;
+}
+
+PGF_API PgfExpr
+pgf_clone_expr(PgfExpr expr, GuPool* pool)
+{
+	PgfExpr new_expr = gu_null_variant;
+
+	GuVariantInfo inf = gu_variant_open(expr);
+	switch (inf.tag) {
+	case PGF_EXPR_ABS: {
+		PgfExprAbs* abs     = inf.data;
+		PgfExprAbs* new_abs =
+			gu_new_variant(PGF_EXPR_ABS,
+						   PgfExprAbs,
+						   &new_expr, pool);
+
+		new_abs->bind_type = abs->bind_type;
+		new_abs->id = gu_string_copy(abs->id, pool);
+		new_abs->body = pgf_clone_expr(abs->body,pool);
+		break;
+	}
+	case PGF_EXPR_APP: {
+		PgfExprApp* app     = inf.data;
+		PgfExprApp* new_app =
+			gu_new_variant(PGF_EXPR_APP,
+						   PgfExprApp,
+						   &new_expr, pool);
+		new_app->fun = pgf_clone_expr(app->fun, pool);
+		new_app->arg = pgf_clone_expr(app->arg, pool);
+		break;
+	}
+	case PGF_EXPR_LIT: {
+		PgfExprLit* lit     = inf.data;
+		PgfExprLit* new_lit =
+			gu_new_variant(PGF_EXPR_LIT,
+						   PgfExprLit,
+						   &new_expr, pool);
+		new_lit->lit = pgf_clone_literal(lit->lit, pool);
+		break;
+	}
+	case PGF_EXPR_META: {
+		PgfExprMeta* meta     = inf.data;
+		PgfExprMeta* new_meta =
+			gu_new_variant(PGF_EXPR_META,
+						   PgfExprMeta,
+						   &new_expr, pool);
+		new_meta->id = meta->id;
+		break;
+	}
+	case PGF_EXPR_FUN: {
+		PgfExprFun* fun     = inf.data;
+		PgfExprFun* new_fun =
+			gu_new_flex_variant(PGF_EXPR_FUN,
+						        PgfExprFun,
+						        fun, strlen(fun->fun)+1,
+						        &new_expr, pool);
+		strcpy(new_fun->fun, fun->fun);
+		break;
+	}
+	case PGF_EXPR_VAR: {
+		PgfExprVar* var     = inf.data;
+		PgfExprVar* new_var =
+			gu_new_variant(PGF_EXPR_VAR,
+						   PgfExprVar,
+						   &new_expr, pool);
+		new_var->var = var->var;
+		break;
+	}
+	case PGF_EXPR_TYPED: {
+		PgfExprTyped* typed = inf.data;
+
+		PgfExprTyped *new_typed =
+			gu_new_variant(PGF_EXPR_TYPED,
+						   PgfExprTyped,
+						   &new_expr, pool);
+		new_typed->expr = pgf_clone_expr(typed->expr, pool);
+		new_typed->type = pgf_clone_type(typed->type, pool);
+		break;
+	}
+	case PGF_EXPR_IMPL_ARG: {
+		PgfExprImplArg* impl     = inf.data;
+		PgfExprImplArg *new_impl =
+			gu_new_variant(PGF_EXPR_IMPL_ARG,
+						   PgfExprImplArg,
+						   &new_expr, pool);
+		new_impl->expr = pgf_clone_expr(impl->expr, pool);
+		break;
+	}
+	default:
+		gu_impossible();
+	}
+
+	return new_expr;
+}
+
+PGF_API PgfType*
+pgf_clone_type(PgfType* type, GuPool* pool)
+{
+	PgfType* new_type =
+		gu_new_flex(pool, PgfType, exprs, type->n_exprs);
+
+	size_t n_hypos = gu_seq_length(type->hypos);
+	new_type->hypos = gu_new_seq(PgfHypo, n_hypos, pool);
+	for (size_t i = 0; i < n_hypos; i++) {
+		PgfHypo* hypo     = gu_seq_index(type->hypos,     PgfHypo, i);
+		PgfHypo* new_hypo = gu_seq_index(new_type->hypos, PgfHypo, i);
+
+		new_hypo->bind_type = hypo->bind_type;
+		new_hypo->cid = gu_string_copy(hypo->cid, pool);
+		new_hypo->type = pgf_clone_type(hypo->type, pool);
+	}
+
+	new_type->cid = gu_string_copy(type->cid, pool);
+
+	new_type->n_exprs = type->n_exprs;
+	for (size_t i = 0; i < new_type->n_exprs; i++) {
+		new_type->exprs[i] = pgf_clone_expr(type->exprs[i], pool);
+	}
+
+	return new_type;
+}
+
 PGF_API prob_t
 pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr)
 {

src/runtime/c/pgf/expr.h

@@ -170,15 +170,6 @@ pgf_expr_unmeta(PgfExpr expr);
 PGF_API_DECL PgfExpr
 pgf_read_expr(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err);
 
-PGF_API_DECL int
-pgf_read_expr_tuple(GuIn* in,
-                    size_t n_exprs, PgfExpr exprs[],
-                    GuPool* pool, GuExn* err);
-
-PGF_API_DECL GuSeq*
-pgf_read_expr_matrix(GuIn* in, size_t n_exprs,
-                     GuPool* pool, GuExn* err);
-
 PGF_API_DECL PgfType*
 pgf_read_type(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err);
 
@@ -197,16 +188,16 @@ pgf_literal_hash(GuHash h, PgfLiteral lit);
 PGF_API_DECL GuHash
 pgf_expr_hash(GuHash h, PgfExpr e);
 
-PGF_API size_t
+PGF_API_DECL size_t
 pgf_expr_size(PgfExpr expr);
 
-PGF_API GuSeq*
+PGF_API_DECL GuSeq*
 pgf_expr_functions(PgfExpr expr, GuPool* pool);
 
-PGF_API PgfExpr
+PGF_API_DECL PgfExpr
 pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool);
 
-PGF_API PgfType*
+PGF_API_DECL PgfType*
 pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool);
 
 typedef struct PgfPrintContext PgfPrintContext;
@@ -238,9 +229,14 @@ PGF_API_DECL void
 pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
                   GuOut *out, GuExn *err);
 
-PGF_API_DECL void
+PGF_API PgfLiteral
-pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
+pgf_clone_literal(PgfLiteral lit, GuPool* pool);
-                     GuOut* out, GuExn* err);
+
+PGF_API PgfExpr
+pgf_clone_expr(PgfExpr expr, GuPool* pool);
+
+PGF_API PgfType*
+pgf_clone_type(PgfType* type, GuPool* pool);
 
 PGF_API_DECL prob_t
 pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr);

src/runtime/c/pgf/graphviz.c

@@ -155,7 +155,7 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok)
 }
 
 static void
-pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun)
+pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, GuString ann, PgfCId fun)
 {
 	PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs);
 
@@ -192,7 +192,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t li
 }
 
 static void
-pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun)
+pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, GuString ann, PgfCId fun)
 {
 	PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs);
 

src/runtime/c/pgf/jit.c

@@ -5,9 +5,6 @@
 #include <pgf/reasoner.h>
 #include <pgf/reader.h>
 #include "lightning.h"
-#if defined(__MINGW32__) || defined(_MSC_VER)
-#include <malloc.h>
-#endif
 
 //#define PGF_JIT_DEBUG
 
@@ -43,18 +40,6 @@ typedef struct {
 #define JIT_VSTATE JIT_V1
 #define JIT_VCLOS  JIT_V2
 
-#if defined(__MINGW32__) || defined(_MSC_VER)
-#include <windows.h>
-
-static int
-getpagesize()
-{
-  SYSTEM_INFO system_info;
-  GetSystemInfo(&system_info);
-  return system_info.dwPageSize;
-}
-#endif
-
 
 static void
 pgf_jit_finalize_page(GuFinalizer* self)
@@ -65,19 +50,8 @@ pgf_jit_finalize_page(GuFinalizer* self)
 static void
 pgf_jit_alloc_page(PgfReader* rdr)
 {
-	void *page;
+	size_t page_size;
-
+	void *page = gu_mem_page_alloc(sizeof(GuFinalizer), &page_size);
-	size_t page_size = getpagesize();
-
-#if defined(ANDROID)
-	if ((page = memalign(page_size, page_size)) == NULL) {	
-#elif defined(__MINGW32__) || defined(_MSC_VER)
-	if ((page = malloc(page_size)) == NULL) {
-#else
-	if (posix_memalign(&page, page_size, page_size) != 0) {
-#endif
-		gu_fatal("Memory allocation failed");
-	}
 
 	GuFinalizer* fin = page;
 	fin->fn = pgf_jit_finalize_page;

src/runtime/c/pgf/linearizer.c

@@ -606,7 +606,7 @@ typedef struct {
 	PgfLzrCachedTag tag;
 	PgfCId cat;
 	int fid;
-	int lin_idx;
+	GuString ann;
 	PgfCId fun;
 } PgfLzrCached;
 
@@ -644,7 +644,7 @@ pgf_lzr_cache_flush(PgfLzrCache* cache, PgfSymbols* form)
 				                        cache->lzr->funcs,
 				                        event->cat,
 				                        event->fid,
-				                        event->lin_idx,
+				                        event->ann,
 				                        event->fun);
 			}
 			break;
@@ -654,7 +654,7 @@ pgf_lzr_cache_flush(PgfLzrCache* cache, PgfSymbols* form)
 				                        cache->lzr->funcs,
 				                        event->cat,
 				                        event->fid,
-				                        event->lin_idx,
+				                        event->ann,
 				                        event->fun);
 			}
 			break;
@@ -709,27 +709,27 @@ found:
 }
 
 static void
-pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun)
+pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, GuString ann, PgfCId fun)
 {
 	PgfLzrCache*  cache = gu_container(funcs, PgfLzrCache, funcs);
 	PgfLzrCached* event = gu_buf_extend(cache->events);
-	event->tag     = PGF_CACHED_BEGIN;
+	event->tag = PGF_CACHED_BEGIN;
-	event->cat     = cat;
+	event->cat = cat;
-	event->fid     = fid;
+	event->fid = fid;
-	event->lin_idx = lin_idx;
+	event->ann = ann;
-	event->fun     = fun;
+	event->fun = fun;
 }
 
 static void
-pgf_lzr_cache_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun)
+pgf_lzr_cache_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, GuString ann, PgfCId fun)
 {
 	PgfLzrCache*  cache = gu_container(funcs, PgfLzrCache, funcs);
 	PgfLzrCached* event = gu_buf_extend(cache->events);
-	event->tag     = PGF_CACHED_END;
+	event->tag = PGF_CACHED_END;
-	event->cat     = cat;
+	event->cat = cat;
-	event->fid     = fid;
+	event->fid = fid;
-	event->lin_idx = lin_idx;
+	event->ann = ann;
-	event->fun     = fun;
+	event->fun = fun;
 }
 
 static void
@@ -918,7 +918,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 		if ((*lzr->funcs)->begin_phrase && fapp->ccat != NULL) {
 			(*lzr->funcs)->begin_phrase(lzr->funcs,
 			                            fapp->ccat->cnccat->abscat->name,
-			                            fapp->fid, lin_idx,
+			                            fapp->fid, fapp->ccat->cnccat->labels[lin_idx],
 			                            fapp->abs_id);
 		}
 
@@ -928,7 +928,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 		if ((*lzr->funcs)->end_phrase && fapp->ccat != NULL) {
 			(*lzr->funcs)->end_phrase(lzr->funcs,
 			                          fapp->ccat->cnccat->abscat->name,
-			                          fapp->fid, lin_idx,
+			                          fapp->fid, fapp->ccat->cnccat->labels[lin_idx],
 			                          fapp->abs_id);
 		}
 		break;
@@ -957,7 +957,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 		
 		if ((*lzr->funcs)->begin_phrase && flit->fid >= 0) {
 			(*lzr->funcs)->begin_phrase(lzr->funcs,
-			                            cat, flit->fid, 0,
+			                            cat, flit->fid, "s",
 			                            "");
 		}
 
@@ -989,7 +989,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 
 		if ((*lzr->funcs)->end_phrase && flit->fid >= 0) {
 			(*lzr->funcs)->end_phrase(lzr->funcs,
-							          cat, flit->fid, 0,
+							          cat, flit->fid, "s",
 							          "");
 		}
 

src/runtime/c/pgf/linearizer.h

@@ -84,10 +84,10 @@ struct PgfLinFuncs
 	void (*symbol_token)(PgfLinFuncs** self, PgfToken tok);
 
 	/// Begin phrase
-	void (*begin_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun);
+	void (*begin_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, GuString ann, PgfCId fun);
 
 	/// End phrase
-	void (*end_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun);
+	void (*end_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, GuString ann, PgfCId fun);
 
 	/// handling nonExist
 	void (*symbol_ne)(PgfLinFuncs** self);