Use modify instead of insert: results mildly better but not significantly

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

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

@@ -19,7 +19,6 @@ main = defaultMainWithHooks simpleUserHooks
   , preInst   = gfPreInst
   , postInst  = gfPostInst
   , postCopy  = gfPostCopy
-  , sDistHook = gfSDist
   }
   where
     gfPreBuild args  = gfPre args . buildDistPref
@@ -29,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)
 

bin/build-binary-dist.sh

@@ -1,15 +1,18 @@
 #! /bin/bash
 
-### This script builds a binary distribution of GF from the source
-### package that this script is a part of. It assumes that you have installed
-### a recent version of the Haskell Platform.
-### Two binary package formats are supported: plain tar files (.tar.gz) and
-### OS X Installer packages (.pkg).
+### This script builds a binary distribution of GF from source.
+### It assumes that you have Haskell and Cabal installed.
+### Two binary package formats are supported (specified with the FMT env var):
+### - plain tar files (.tar.gz)
+### - macOS installer packages (.pkg)
 
 os=$(uname)     # Operating system name (e.g. Darwin or Linux)
 hw=$(uname -m)  # Hardware name (e.g. i686 or x86_64)
 
-# GF version number:
+cabal="cabal v1-" # Cabal >= 2.4
+# cabal="cabal " # Cabal <= 2.2
+
+## Get GF version number from Cabal file
 ver=$(grep -i ^version: gf.cabal | sed -e 's/version://' -e 's/ //g')
 
 name="gf-$ver"
@@ -29,6 +32,7 @@ set -x                             # print commands before executing them
 pushd src/runtime/c
 bash setup.sh configure --prefix="$prefix"
 bash setup.sh build
+bash setup.sh install prefix="$prefix" # hack required for GF build on macOS
 bash setup.sh install prefix="$destdir$prefix"
 popd
 
@@ -38,11 +42,11 @@ if which >/dev/null python; then
     EXTRA_INCLUDE_DIRS="$extrainclude" EXTRA_LIB_DIRS="$extralib" python setup.py build
     python setup.py install --prefix="$destdir$prefix"
     if [ "$fmt" == pkg ] ; then
-	# A hack for Python on OS X to find the PGF modules
-	pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
-	pydest="$destdir/Library/Python/$pyver/site-packages"
-	mkdir -p "$pydest"
-	ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$pydest"
+        # A hack for Python on macOS to find the PGF modules
+        pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
+        pydest="$destdir/Library/Python/$pyver/site-packages"
+        mkdir -p "$pydest"
+        ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$pydest"
     fi
     popd
 else
@@ -53,52 +57,42 @@ fi
 if which >/dev/null javac && which >/dev/null jar ; then
     pushd src/runtime/java
     rm -f libjpgf.la # In case it contains the wrong INSTALL_PATH
-    if make CFLAGS="-I$extrainclude -L$extralib" INSTALL_PATH="$prefix/lib"
+    if make CFLAGS="-I$extrainclude -L$extralib" INSTALL_PATH="$prefix"
     then
-	make INSTALL_PATH="$destdir$prefix/lib" install
+        make INSTALL_PATH="$destdir$prefix" install
     else
-	echo "*** Skipping the Java binding because of errors"
+        echo "Skipping the Java binding because of errors"
     fi
     popd
 else
     echo "Java SDK is not installed, so the Java binding will not be included"
 fi
 
+## To find dynamic C run-time libraries when building GF below
+export DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib"
+
 ## Build GF, with C run-time support enabled
-cabal install -w "$ghc" --only-dependencies -fserver -fc-runtime $extra
-cabal configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
-DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib" cabal build
-  # Building the example grammars will fail, because the RGL is missing
-cabal copy --destdir="$destdir"  # create www directory
-
-## Build the RGL and copy it to $destdir
-PATH=$PWD/dist/build/gf:$PATH
-export GF_LIB_PATH="$(dirname $(find "$destdir" -name www))/lib"   # hmm
-mkdir -p "$GF_LIB_PATH"
-pushd ../gf-rgl
-make build
-make copy
-popd
-
-# Build GF again, including example grammars that need the RGL
-DYLD_LIBRARY_PATH="$extralib" LD_LIBRARY_PATH="$extralib" cabal build
+${cabal}install -w "$ghc" --only-dependencies -fserver -fc-runtime $extra
+${cabal}configure -w "$ghc" --prefix="$prefix" -fserver -fc-runtime $extra
+${cabal}build
 
 ## Copy GF to $destdir
-cabal copy --destdir="$destdir"
+${cabal}copy --destdir="$destdir"
 libdir=$(dirname $(find "$destdir" -name PGF.hi))
-cabal register --gen-pkg-config=$libdir/gf-$ver.conf
+${cabal}register --gen-pkg-config="$libdir/gf-$ver.conf"
 
 ## Create the binary distribution package
 case $fmt in
     tar.gz)
-	targz="$name-bin-$hw-$os.tar.gz"     # the final tar file
-	tar -C "$destdir/$prefix" -zcf "dist/$targz" .
-	echo "Created $targz, consider renaming it to something more user friendly"
-	;;
+        targz="$name-bin-$hw-$os.tar.gz"     # the final tar file
+        tar --directory "$destdir/$prefix" --gzip --create --file "dist/$targz" .
+        echo "Created $targz"
+        ;;
     pkg)
-	pkg=$name.pkg
-	pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
-	echo "Created $pkg"
+        pkg=$name.pkg
+        pkgbuild --identifier org.grammaticalframework.gf.pkg --version "$ver" --root "$destdir" --install-location / dist/$pkg
+        echo "Created $pkg"
 esac
 
+## Cleanup
 rm -r "$destdir"

bin/template.html

@@ -82,9 +82,10 @@ $body$
           <li><a href="http://cloud.grammaticalframework.org/">GF Cloud</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>

bin/update_html

@@ -147,7 +147,7 @@ else
     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" ] || [ "$template" -nt "$html" ] ; then
       render_md_html "$file" "$html"

debian/changelog

@@ -1,3 +1,9 @@
+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

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, pandoc
+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
@@ -24,19 +24,15 @@ SET_LDL=LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
 
 override_dh_auto_build:
 	cd src/runtime/python && EXTRA_INCLUDE_DIRS=$(CURDIR)/src/runtime/c EXTRA_LIB_DIRS=$(CURDIR)/src/runtime/c/.libs python setup.py build
-	cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr/lib
+	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 # builds gf, fails to build example grammars
-	export $(SET_LDL); PATH=$(CURDIR)/dist/build/gf:$$PATH && make -C ../gf-rgl build
-	GF_LIB_PATH=$(CURDIR)/../gf-rgl/dist $(SET_LDL) cabal build # have RGL now, ok to build example grammars
-	make html
+	-$(SET_LDL) cabal build
 
 override_dh_auto_install:
-	$(SET_LDL) cabal copy --destdir=$(CURDIR)/debian/gf # creates www directory
-	export GF_LIB_PATH="$$(dirname $$(find "$(CURDIR)/debian/gf" -name www))/lib" && echo "GF_LIB_PATH=$$GF_LIB_PATH" && mkdir -p "$$GF_LIB_PATH" && make -C ../gf-rgl copy
+	$(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:

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.

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

@@ -1809,6 +1809,23 @@ As the last rule, subtyping is transitive:
 -   if *A* is a subtype of *B* and *B* is a subtype of *C*, then *A* is
     a subtype of *C*.
 
+### List categories
+
+[]{#lists}
+
+Since categories of lists of elements of another category are a common idiom, the following syntactic sugar is available:
+
+    cat [C] {n}
+
+abbreviates a set of three judgements:
+
+   cat ListC ;
+   fun BaseC : C -> ... -> C -> ListC ; --n C’s
+   fun ConsC : C -> ListC -> ListC
+
+The functions `BaseC` and `ConsC` are automatically generated in the abstract syntax, but their linearizations, as well as the linearization type of `ListC`, must be defined manually. The type expression `[C]` is in all contexts interchangeable with `ListC`.
+
+More information on lists in GF can be found [here](https://inariksit.github.io/gf/2021/02/22/lists.html).
 
 ### Tables and table types
 
@@ -2113,7 +2130,7 @@ of *x*, and the application thereby disappears.
 
 []{#reuse}
 
-*This section is valid for GF 3.0, which abandons the \"lock field\"*
+*This section is valid for GF 3.0, which abandons the \"[lock field](https://inariksit.github.io/gf/2018/05/25/subtyping-gf.html#lock-fields)\"*
 *discipline of GF 2.8.*
 
 As explained [here](#openabstract), abstract syntax modules can be

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/tutorial/gf-tutorial.t2t

@@ -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
@@ -2475,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
 
@@ -2488,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
-```
-
 
 
 
@@ -2651,12 +2646,12 @@ The verb //switch off// is called a
 
 We can define transitive verbs and their combinations as follows:
 ```
-  lincat TV = {s : Number => Str ; part : Str} ;
+  lincat V2 = {s : Number => Str ; part : Str} ;
 
-  fun AppTV : Item -> TV -> Item -> Phrase ;
+  fun AppV2 : Item -> V2 -> Item -> Phrase ;
 
-  lin AppTV subj tv obj =
-    {s = subj.s ++ tv.s ! subj.n ++ obj.s ++ tv.part} ;
+  lin AppV2 subj v2 obj =
+    {s = subj.s ++ v2.s ! subj.n ++ obj.s ++ v2.part} ;
 ```
 
 **Exercise**. Define the language ``a^n b^n c^n`` in GF, i.e.
@@ -2722,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.
@@ -2757,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
 ```
@@ -2948,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//.
@@ -2969,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
@@ -3718,49 +3717,25 @@ Concrete syntax does not know if a category is a dependent type.
 ```
 Notice that the ``Kind`` argument is suppressed in linearization.
 
-Parsing with dependent types is performed in two phases:
+Parsing with dependent types consists of two phases:
 + context-free parsing
 + filtering through type checker
 
+Parsing a type-correct command works as expected:
 
-By just doing the first phase, the ``kind`` argument is not found:
 ```
   > parse "dim the light"
-  CAction ? dim (DKindOne light)
-```
-Moreover, type-incorrect commands are not rejected:
-```
-  > parse "dim the fan"
-  CAction ? dim (DKindOne fan)
-```
-The term ``?`` is a **metavariable**, returned by the parser
-for any subtree that is suppressed by a linearization rule.
-These are the same kind of metavariables as were used #Rsecediting
-to mark incomplete parts of trees in the syntax editor.
-
-
-
-#NEW
-
-===Solving metavariables===
-
-Use the command ``put_tree = pt`` with the option ``-typecheck``:
-```
-  > parse "dim the light" | put_tree -typecheck
   CAction light dim (DKindOne light)
 ```
-The ``typecheck`` process may fail, in which case an error message
-is shown and no tree is returned:
+However, type-incorrect commands are rejected by the typecheck:
 ```
-  > parse "dim the fan" | put_tree -typecheck
-
-  Error in tree UCommand (CAction ? 0 dim (DKindOne fan)) :
-    (? 0 <> fan) (? 0 <> light)
+  > parse "dim the fan"
+  The parsing is successful but the type checking failed with error(s):
+    Couldn't match expected type Device light
+       against the interred type Device fan
+    In the expression: DKindOne fan       
 ```
 
-
-
-
 #NEW
 
 ==Polymorphism==
@@ -3786,23 +3761,19 @@ to express Haskell-type library functions:
     \_,_,_,f,x,y -> f y x ;
 ```
 
-
 #NEW
 
 ===Dependent types: exercises===
 
 1. Write an abstract syntax module with above contents
 and an appropriate English concrete syntax. Try to parse the commands
-//dim the light// and //dim the fan//, with and without ``solve`` filtering.
+//dim the light// and //dim the fan//.
 
-
-2. Perform random and exhaustive generation, with and without
-``solve`` filtering.
+2. Perform random and exhaustive generation.
 
 3. Add some device kinds and actions to the grammar.
 
 
-
 #NEW
 
 ==Proof objects==
@@ -3912,7 +3883,6 @@ fun
 Classes for new actions can be added incrementally.
 
 
-
 #NEW
 
 ==Variable bindings==
@@ -4200,7 +4170,8 @@ We construct a calculator with addition, subtraction, multiplication, and
 division of integers.
 ```
   abstract Calculator = {
-
+  flags startcat = Exp ;
+  
   cat Exp ;
 
   fun
@@ -4226,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 ;
@@ -4737,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
 ```

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

@@ -114,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**
 
@@ -171,6 +171,20 @@ 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.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.3-git
+version: 3.10.4-git
 
 cabal-version: >= 1.22
 build-type: Custom
@@ -47,10 +47,6 @@ custom-setup
     filepath,
     process >=1.0.1.1
 
---source-repository head
---  type:     darcs
---  location: http://www.grammaticalframework.org/
-
 source-repository head
   type:     git
   location: https://github.com/GrammaticalFramework/gf-core.git
@@ -67,12 +63,17 @@ flag network-uri
    description: Get Network.URI from the network-uri package
    default: True
 
-executable gf
-  hs-source-dirs: src/programs
-  main-is: gf-main.hs
+--flag new-comp
+--  Description: Make -new-comp the default
+--  Default:     True
+
+flag c-runtime
+  Description: Include functionality from the C run-time library (which must be installed already)
+  Default:     False
+
+Library
   default-language:    Haskell2010
-  build-depends: pgf2,
-                 base >= 4.6 && <5,
+  build-depends: base >= 4.6 && <5,
                  array,
                  containers,
                  bytestring,
@@ -81,27 +82,85 @@ executable gf
                  pretty,
                  mtl,
                  exceptions,
+                 fail,
+                 -- For compatability with ghc < 8
+                 -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
+                 transformers-compat,
                  ghc-prim,
-                 filepath, directory>=1.2, time,
-                 process, haskeline, parallel>=3, json
-  ghc-options: -threaded
-
-  if impl(ghc>=7.0)
-    ghc-options: -rtsopts -with-rtsopts=-I5
-    if impl(ghc<7.8)
-      ghc-options: -with-rtsopts=-K64M
-
-  ghc-prof-options: -auto-all
-
-  hs-source-dirs: src/compiler
+                 text,
+                 hashable,
+                 unordered-containers
+  hs-source-dirs: src/runtime/haskell
 
   other-modules:
+    -- not really part of GF but I have changed the original binary library
+    -- and we have to keep the copy for now.
+    Data.Binary
+    Data.Binary.Put
+    Data.Binary.Get
+    Data.Binary.Builder
+    Data.Binary.IEEE754
+
+--ghc-options: -fwarn-unused-imports
+--if impl(ghc>=7.8)
+--  ghc-options: +RTS -A20M -RTS
+  ghc-prof-options: -fprof-auto
+
+  exposed-modules:
+    PGF
+    PGF.Internal
+    PGF.Haskell
+    LPGF
+
+  other-modules:
+    PGF.Data
+    PGF.Macros
+    PGF.Binary
+    PGF.Optimize
+    PGF.Printer
+    PGF.CId
+    PGF.Expr
+    PGF.Generate
+    PGF.Linearize
+    PGF.Morphology
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Probabilistic
+    PGF.SortTop
+    PGF.Tree
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Forest
+    PGF.TrieMap
+    PGF.VisualizeTree
+    PGF.ByteCode
+    PGF.OldBinary
+    PGF.Utilities
+
+  if flag(c-runtime)
+    exposed-modules: PGF2
+    other-modules:   PGF2.FFI PGF2.Expr PGF2.Type
+                     GF.Interactive2 GF.Command.Commands2
+    hs-source-dirs:  src/runtime/haskell-bind
+    build-tools:     hsc2hs
+    extra-libraries: pgf gu
+    c-sources:       src/runtime/haskell-bind/utils.c
+    cc-options:      -std=c99
+
+---- GF compiler as a library:
+
+  build-depends: filepath, directory>=1.2, time,
+                 process, haskeline, parallel>=3, json
+
+  hs-source-dirs: src/compiler
+  exposed-modules:
     GF
     GF.Support
     GF.Text.Pretty
     GF.Text.Lexing
     GF.Grammar.Canonical
 
+  other-modules:
     GF.Main GF.Compiler GF.Interactive
 
     GF.Compile GF.CompileInParallel GF.CompileOne  GF.Compile.GetGrammar
@@ -122,7 +181,6 @@ executable gf
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.AppPredefined
     GF.Compile.Compute.ConcreteNew
     GF.Compile.Compute.Predef
     GF.Compile.Compute.Value
@@ -130,17 +188,20 @@ executable gf
     GF.Compile.Export
     GF.Compile.GenerateBC
     GF.Compile.GeneratePMCFG
+    GF.Compile.GrammarToLPGF
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
     GF.Compile.Optimize
-    GF.Compile.OptimizePGF
     GF.Compile.PGFtoHaskell
     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
     GF.Compile.Rename
     GF.Compile.SubExOpt
@@ -157,6 +218,7 @@ executable gf
     GF.Data.ErrM
     GF.Data.Graph
     GF.Data.Graphviz
+    GF.Data.IntMapBuilder
     GF.Data.Relation
     GF.Data.Str
     GF.Data.Utilities
@@ -210,17 +272,11 @@ executable gf
     GF.System.Signal
     GF.Text.Clitics
     GF.Text.Coding
-    GF.Text.Lexing
     GF.Text.Transliterations
     Paths_gf
-    
-    -- not really part of GF but I have changed the original binary library
-    -- and we have to keep the copy for now.
-    Data.Binary
-    Data.Binary.Put
-    Data.Binary.Get
-    Data.Binary.Builder
-    Data.Binary.IEEE754
+
+  if flag(c-runtime)
+    cpp-options: -DC_RUNTIME
 
   if flag(server)
     build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7,
@@ -243,6 +299,8 @@ executable gf
       CGIUtils
       Cache
       Fold
+      ExampleDemo
+      ExampleService
     hs-source-dirs: src/server src/server/transfer src/example-based
 
   if flag(interrupt)
@@ -253,6 +311,7 @@ executable gf
 
   if impl(ghc>=7.8)
     build-tools: happy>=1.19, alex>=3.1
+--  ghc-options: +RTS -A20M -RTS
   else
     build-tools: happy, alex>=3
 
@@ -263,13 +322,36 @@ executable gf
   else
     build-depends: unix, terminfo>=0.4
 
+  if impl(ghc>=8.2)
+    ghc-options: -fhide-source-paths
 
-test-suite rgl-tests
-  type:           exitcode-stdio-1.0
-  main-is:        run.hs
-  hs-source-dirs: lib/tests/
-  build-depends:  base, HTF, process, HUnit, filepath, directory
+Executable gf
+  hs-source-dirs: src/programs
+  main-is: gf-main.hs
   default-language:    Haskell2010
+  build-depends: gf, base
+  ghc-options: -threaded
+--ghc-options: -fwarn-unused-imports
+
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts -with-rtsopts=-I5
+    if impl(ghc<7.8)
+      ghc-options: -with-rtsopts=-K64M
+
+  ghc-prof-options: -auto-all
+
+  if impl(ghc>=8.2)
+    ghc-options: -fhide-source-paths
+
+executable pgf-shell
+--if !flag(c-runtime)
+  buildable: False
+  main-is:             pgf-shell.hs
+  hs-source-dirs:      src/runtime/haskell-bind/examples
+  build-depends:       gf, base, containers, mtl, lifted-base
+  default-language:    Haskell2010
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts
 
 test-suite gf-tests
   type:           exitcode-stdio-1.0
@@ -277,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,9 +22,9 @@
   <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 class="mb-2">
       <li><a href="https://www.youtube.com/watch?v=x1LFbDQhbso">Google Tech Talk</a></li>
@@ -39,6 +39,7 @@
         /
         <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">
@@ -47,7 +48,7 @@
     </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 class="mb-2">
@@ -55,6 +56,7 @@
       <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">
@@ -63,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 class="mb-2">
       <li><a href="doc/gf-developers.html">Developers Guide</a></li>
       <!-- <li><a href="/~hallgren/gf-experiment/browse/">Browse Source Code</a></li> -->
-      <li><a href="http://hackage.haskell.org/package/gf/docs/PGF.html">PGF library API (Haskell runtime)</a></li>
-      <li><a href="doc/runtime-api.html">PGF library API (C runtime)</a></li>
+      <li>PGF library API:<br>
+        <a href="http://hackage.haskell.org/package/gf/docs/PGF.html">Haskell</a> /
+        <a href="doc/runtime-api.html">C&nbsp;runtime</a>
+      </li>
       <li><a href="http://hackage.haskell.org/package/gf/docs/GF.html">GF compiler API</a></li>
       <!-- <li><a href="src/ui/android/README">GF on Android (new)</a></li>
       <li><a href="/android/">GF on Android (old) </a></li> -->
       <li><a href="doc/gf-editor-modes.html">Text Editor Support</a></li>
+      <li><a href="http://www.grammaticalframework.org/~john/rgl-browser/">RGL source browser</a></li>
     </ul>
   </div>
 
-  <div class="col-sm-6 col-md-3">
+  <div class="col-sm-6 col-md-3 mb-4">
     <h3>Contribute</h3>
     <ul 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="//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>
@@ -169,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>
 
@@ -222,6 +228,14 @@ 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="//school.grammaticalframework.org/2018/">Sixth GF Summer School</a> in Stellenbosch (South Africa), 3–14 December 2018
@@ -324,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,
@@ -338,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,
@@ -354,7 +372,9 @@ 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,

src/compiler/GF/Command/Abstract.hs

@@ -1,6 +1,6 @@
 module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Term) where
 
-import PGF2(Expr,showExpr)
+import PGF(CId,mkCId,Expr,showExpr)
 import GF.Grammar.Grammar(Term)
 
 type Ident = String
@@ -11,7 +11,7 @@ type Pipe = [Command]
 
 data Command
    = Command Ident [Option] Argument
-   deriving Show
+   deriving (Eq,Ord,Show)
 
 data Option
   = OOpt Ident
@@ -29,7 +29,13 @@ data Argument
   | ATerm Term
   | ANoArg
   | AMacro Ident
-  deriving Show
+  deriving (Eq,Ord,Show)
+
+valCIdOpts :: String -> CId -> [Option] -> CId
+valCIdOpts flag def opts =
+  case [v | OFlag f (VId v) <- opts, f == flag] of
+    (v:_) -> mkCId v
+    _     -> def
 
 valIntOpts :: String -> Int -> [Option] -> Int
 valIntOpts flag def opts =
@@ -43,18 +49,6 @@ valStrOpts flag def opts =
     v:_ -> valueString v
     _   -> def
 
-maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
-maybeIntOpts flag def fn opts =
-  case [v | OFlag f (VInt v) <- opts, f == flag] of
-    (v:_) -> fn v
-    _     -> def
-
-maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
-maybeStrOpts flag def fn opts =
-  case listFlags flag opts of
-    v:_ -> fn (valueString v)
-    _   -> def
-
 listFlags flag opts = [v | OFlag f v <- opts, f == flag]
 
 valueString v =

src/compiler/GF/Command/CommandInfo.hs

@@ -3,7 +3,8 @@ import GF.Command.Abstract(Option,Expr,Term)
 import GF.Text.Pretty(render)
 import GF.Grammar.Printer() -- instance Pretty Term
 import GF.Grammar.Macros(string2term)
-import PGF2(mkStr,unStr,showExpr)
+import qualified PGF as H(showExpr)
+import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ----
 
 data CommandInfo m = CommandInfo {
   exec     :: [Option] -> CommandArguments -> m CommandOutput,
@@ -37,19 +38,21 @@ class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
 
 --------------------------------------------------------------------------------
 
-data CommandArguments = Exprs [(Expr,Float)] | Strings [String] | Term Term
+data CommandArguments = Exprs [Expr] | Strings [String] | Term Term
 
 newtype CommandOutput = Piped (CommandArguments,String) ---- errors, etc
 
 -- ** Converting command output
 fromStrings ss         = Piped (Strings ss, unlines ss)
-fromExprs show_p es    = Piped (Exprs es,unlines (map (\(e,p) -> (if show_p then (++) ("["++show p++"] ") else id) (showExpr [] e)) es))
+fromExprs   es         = Piped (Exprs es,unlines (map (H.showExpr []) es))
 fromString  s          = Piped (Strings [s], s)
 pipeWithMessage es msg = Piped (Exprs es,msg)
 pipeMessage msg        = Piped (Exprs [],msg)
 pipeExprs   es         = Piped (Exprs es,[]) -- only used in emptyCommandInfo
 void                   = Piped (Exprs [],"")
 
+stringAsExpr = H.ELit . H.LStr -- should be a pattern macro
+
 -- ** Converting command input
 
 toStrings args =
@@ -58,23 +61,23 @@ toStrings args =
       Exprs es -> zipWith showAsString (True:repeat False) es
       Term t -> [render t]
   where
-    showAsString first (e,p) =
-      case unStr e of
-        Just s  -> s
-        Nothing -> ['\n'|not first] ++
-                   showExpr [] e ---newline needed in other cases than the first
+    showAsString first t =
+      case t of
+        H.ELit (H.LStr s) -> s
+        _ -> ['\n'|not first] ++
+             H.showExpr [] t ---newline needed in other cases than the first
 
 toExprs args =
   case args of
-    Exprs es -> map fst es
-    Strings ss -> map mkStr ss
-    Term t -> [mkStr (render t)]
+    Exprs es -> es
+    Strings ss -> map stringAsExpr ss
+    Term t -> [stringAsExpr (render t)]
 
 toTerm args =
   case args of
     Term t -> t
     Strings ss -> string2term $ unwords ss -- hmm
-    Exprs es -> string2term $ unwords $ map (showExpr [] . fst) es -- hmm
+    Exprs es -> string2term $ unwords $ map (H.showExpr []) es -- hmm
 
 -- ** Creating documentation
 

src/compiler/GF/Command/Commands.hs

@@ -1,12 +1,16 @@
 {-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 module GF.Command.Commands (
-  HasPGF(..),pgfCommands,
+  PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
   options,flags,
   ) where
-import Prelude hiding (putStrLn)
+import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
-import PGF2
-import PGF2.Internal(writePGF)
+import PGF
+
+import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin)
+import PGF.Internal(abstract,funs,cats,Expr(EFun)) ----
+import PGF.Internal(ppFun,ppCat)
+import PGF.Internal(optimizePGF)
 
 import GF.Compile.Export
 import GF.Compile.ToAPI
@@ -24,25 +28,28 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute
 
 import GF.Data.Operations
 
-import Data.Char
+import PGF.Internal (encodeFile)
 import Data.List(intersperse,nub)
 import Data.Maybe
 import qualified Data.Map as Map
 import GF.Text.Pretty
 import Data.List (sort)
-import Control.Monad(mplus)
+import qualified Control.Monad.Fail as Fail
+--import Debug.Trace
 
-class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF)
 
-instance (Monad m,HasPGF m) => TypeCheckArg m where
-  typeCheckArg e = do mb_pgf <- getPGF
-                      case mb_pgf of
-                        Just pgf -> either fail
-                                           (return . fst)
-                                           (inferExpr pgf e)
-                        Nothing  -> fail "Import a grammar before using this command"
+data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
 
-pgfCommands :: HasPGF m => Map.Map String (CommandInfo m)
+pgfEnv pgf = Env pgf mos
+  where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
+
+class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
+
+instance (Monad m,HasPGFEnv m,Fail.MonadFail m) => TypeCheckArg m where
+  typeCheckArg e = (either (fail . render . ppTcError) (return . fst)
+                    . flip inferExpr e . pgf) =<< getPGFEnv
+
+pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
 pgfCommands = Map.fromList [
   ("aw", emptyCommandInfo {
      longname = "align_words",
@@ -55,7 +62,7 @@ pgfCommands = Map.fromList [
        "by the view flag. The target format is png, unless overridden by the",
        "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)."
        ],
-     exec = needPGF $ \ opts arg pgf -> do
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
          let es = toExprs arg
          let langs = optLangs pgf opts
          if isOpt "giza" opts
@@ -67,7 +74,7 @@ pgfCommands = Map.fromList [
              let grph = if null es then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align
              return $ fromString grph
            else do
-             let grphs = map (graphvizWordAlignment langs graphvizDefaults) es
+             let grphs = map (graphvizAlignment pgf langs) es
              if isFlag "view" opts || isFlag "format" opts
                then do
                  let view = optViewGraph opts
@@ -89,7 +96,6 @@ pgfCommands = Map.fromList [
        ("view",  "program to open the resulting file")
        ]
     }),
-
   ("ca", emptyCommandInfo {
      longname = "clitic_analyse",
      synopsis = "print the analyses of all words into stems and clitics",
@@ -100,17 +106,16 @@ pgfCommands = Map.fromList [
        "by the flag '-clitics'. The list of stems is given as the list of words",
        "of the language given by the '-lang' flag."
        ],
-     exec  = needPGF $ \opts ts pgf -> do
-               concr <- optLang pgf opts
-               case opts of
-                 _ | isOpt "raw" opts ->
-                       return . fromString .
-                       unlines . map (unwords . map (concat . intersperse "+")) .
-                       map (getClitics (not . null . lookupMorpho concr) (optClitics opts)) .
-                       concatMap words $ toStrings ts
-                 _ -> return . fromStrings .
-                      getCliticsText (not . null . lookupMorpho concr) (optClitics opts) .
-                      concatMap words $ toStrings ts,
+     exec  = getEnv $ \opts ts env -> case opts of
+               _ | isOpt "raw" opts ->
+                    return . fromString .
+                    unlines . map (unwords . map (concat . intersperse "+")) .
+                    map (getClitics (isInMorpho (optMorpho env opts)) (optClitics opts)) .
+                    concatMap words $ toStrings ts
+               _ ->
+                    return . fromStrings .
+                    getCliticsText (isInMorpho (optMorpho env opts)) (optClitics opts) .
+                    concatMap words $ toStrings ts,
      flags = [
        ("clitics","the list of possible clitics (comma-separated, no spaces)"),
        ("lang",   "the language of analysis")
@@ -142,19 +147,19 @@ pgfCommands = Map.fromList [
        ],
      flags = [
        ("file","the file to be converted (suffix .gfe must be given)"),
-       ("lang","the language in which to parse")
+       ("lang","the language in which to parse"),
+       ("probs","file with probabilities to rank the parses")
        ],
-     exec = needPGF $ \opts _ pgf -> do
+     exec = getEnv $ \ opts _ env@(Env pgf mos) -> do
        let file = optFile opts
+       pgf <- optProbs opts pgf
        let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
-       concr <- optLang pgf opts
-       let conf = configureExBased pgf concr printer
+       let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
        (file',ws) <- restricted $ parseExamplesInGrammar conf file
        if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
        return (fromString ("wrote " ++ file')),
      needsTypeCheck = False
      }),
-
   ("gr", emptyCommandInfo {
      longname = "generate_random",
      synopsis = "generate random trees in the current abstract syntax",
@@ -169,53 +174,54 @@ pgfCommands = Map.fromList [
      explanation = unlines [
        "Generates a list of random trees, by default one tree.",
        "If a tree argument is given, the command completes the Tree with values to",
-       "all metavariables in the tree. The generation can be biased by probabilities",
-       "if the grammar was compiled with option -probs"
-       ],
-     options = [
-       ("show_probs", "show the probability of each result")
+       "all metavariables in the tree. The generation can be biased by probabilities,",
+       "given in a file in the -probs flag."
        ],
      flags = [
        ("cat","generation category"),
        ("lang","uses only functions that have linearizations in all these languages"),
-       ("number","number of trees generated")
+       ("number","number of trees generated"),
+       ("depth","the maximum generation depth"),
+       ("probs", "file with biased probabilities (format 'f 0.4' one by line)")
        ],
-     exec = needPGF $ \opts arg pgf -> do
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
+       pgf <- optProbs opts (optRestricted opts pgf)
        gen <- newStdGen
+       let dp = valIntOpts "depth" 4 opts
        let ts  = case mexp (toExprs arg) of
-                   Just ex -> generateRandomFrom gen pgf ex
-                   Nothing -> generateRandom     gen pgf (optType pgf opts)
-       returnFromExprs (isOpt "show_probs" opts) $ take (optNum opts) ts
+                   Just ex -> generateRandomFromDepth gen pgf ex (Just dp)
+                   Nothing -> generateRandomDepth     gen pgf (optType pgf opts) (Just dp)
+       returnFromExprs $ take (optNum opts) ts
      }),
-
   ("gt", emptyCommandInfo {
      longname = "generate_trees",
      synopsis = "generates a list of trees, by default exhaustive",
      explanation = unlines [
-       "Generates all trees of a given category.",
+       "Generates all trees of a given category. By default, ",
+       "the depth is limited to 4, but this can be changed by a flag.",
        "If a Tree argument is given, the command completes the Tree with values",
        "to all metavariables in the tree."
        ],
-     options = [
-       ("show_probs", "show the probability of each result")
-       ],
      flags = [
        ("cat","the generation category"),
+       ("depth","the maximum generation depth"),
        ("lang","excludes functions that have no linearization in this language"),
        ("number","the number of trees generated")
        ],
      examples = [
-       mkEx "gt                     -- all trees in the startcat",
+       mkEx "gt                     -- all trees in the startcat, to depth 4",
        mkEx "gt -cat=NP -number=16  -- 16 trees in the category NP",
+       mkEx "gt -cat=NP -depth=2    -- trees in the category NP to depth 2",
        mkEx "gt (AdjCN ? (UseN ?))  -- trees of form (AdjCN ? (UseN ?))"
        ],
-     exec = needPGF $ \opts arg pgf -> do
-       let es = case mexp (toExprs arg) of
-                  Just ex -> generateAllFrom pgf ex
-                  Nothing -> generateAll     pgf (optType pgf opts)
-       returnFromExprs (isOpt "show_probs" opts) $ takeOptNum opts es
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
+       let pgfr = optRestricted opts pgf
+       let dp = valIntOpts "depth" 4 opts
+       let ts = case mexp (toExprs arg) of
+                  Just ex -> generateFromDepth pgfr ex (Just dp)
+                  Nothing -> generateAllDepth pgfr (optType pgf opts) (Just dp)
+       returnFromExprs $ take (optNumInf opts) ts
      }),
-
   ("i", emptyCommandInfo {
      longname = "import",
      synopsis = "import a grammar from source code or compiled .pgf file",
@@ -236,28 +242,33 @@ pgfCommands = Map.fromList [
        ("probs","file with biased probabilities for generation")
        ],
      options = [
+       -- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
        ("retain","retain operations (used for cc command)"),
        ("src",   "force compilation from source"),
        ("v",     "be verbose - show intermediate status information")
        ],
      needsTypeCheck = False
      }),
-
   ("l", emptyCommandInfo {
      longname = "linearize",
      synopsis = "convert an abstract syntax expression to string",
      explanation = unlines [
-       "Shows the linearization of a tree by the grammars in scope.",
+       "Shows the linearization of a Tree by the grammars in scope.",
        "The -lang flag can be used to restrict this to fewer languages.",
        "A sequence of string operations (see command ps) can be given",
        "as options, and works then like a pipe to the ps command, except",
-       "that it only affect the strings, not e.g. the table labels."
+       "that it only affect the strings, not e.g. the table labels.",
+       "These can be given separately to each language with the unlexer flag",
+       "whose results are prepended to the other lexer flags. The value of the",
+       "unlexer flag is a space-separated list of comma-separated string operation",
+       "sequences; see example."
        ],
      examples = [
        mkEx "l -lang=LangSwe,LangNor no_Utt   -- linearize tree to LangSwe and LangNor",
-       mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table"
+       mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
+       mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
        ],
-     exec = needPGF $ \ opts ts pgf -> return . fromStrings . optLins pgf opts $ toExprs ts,
+     exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings . optLins pgf opts $ toExprs ts,
      options = [
        ("all",    "show all forms and variants, one by line (cf. l -list)"),
        ("bracket","show tree structure with brackets and paths to nodes"),
@@ -265,13 +276,33 @@ pgfCommands = Map.fromList [
        ("list","show all forms and variants, comma-separated on one line (cf. l -all)"),
        ("multi","linearize to all languages (default)"),
        ("table","show all forms labelled by parameters"),
+       ("tabtreebank","show the tree and its linearizations on a tab-separated line"),
+       ("treebank","show the tree and tag linearizations with language names")
+       ] ++ stringOpOptions,
+     flags = [
+       ("lang","the languages of linearization (comma-separated, no spaces)"),
+       ("unlexer","set unlexers separately to each language (space-separated)")
+       ]
+     }),
+  ("lc", emptyCommandInfo {
+     longname = "linearize_chunks",
+     synopsis = "linearize a tree that has metavariables in maximal chunks without them",
+     explanation = unlines [
+       "A hopefully temporary command, intended to work around the type checker that fails",
+       "trees where a function node is a metavariable."
+       ],
+     examples = [
+       mkEx "l -lang=LangSwe,LangNor -chunks ? a b (? c d)"
+       ],
+     exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings $ optLins pgf (opts ++ [OOpt "chunks"]) (toExprs ts),
+     options = [
        ("treebank","show the tree and tag linearizations with language names")
        ] ++ stringOpOptions,
      flags = [
        ("lang","the languages of linearization (comma-separated, no spaces)")
-       ]
+       ],
+     needsTypeCheck = False
      }),
-
   ("ma", emptyCommandInfo {
      longname = "morpho_analyse",
      synopsis = "print the morphological analyses of all words in the string",
@@ -279,20 +310,18 @@ pgfCommands = Map.fromList [
        "Prints all the analyses of space-separated words in the input string,",
        "using the morphological analyser of the actual grammar (see command pg)"
        ],
-     exec  = needPGF $ \opts ts pgf -> do
-               concr <- optLang pgf opts
-               case opts of
-                 _ | isOpt "missing" opts ->
-                      return . fromString . unwords .
-                      morphoMissing concr .
-                      concatMap words $ toStrings ts
-                 _ | isOpt "known" opts ->
-                      return . fromString . unwords .
-                      morphoKnown concr .
-                      concatMap words $ toStrings ts
-                 _ -> return . fromString . unlines .
-                      map prMorphoAnalysis . concatMap (morphos pgf opts) .
-                      concatMap words $ toStrings ts,
+     exec  = getEnv $ \opts ts env -> case opts of
+               _ | isOpt "missing" opts ->
+                    return . fromString . unwords .
+                    morphoMissing (optMorpho env opts) .
+                    concatMap words $ toStrings ts
+               _ | isOpt "known" opts ->
+                    return . fromString . unwords .
+                    morphoKnown (optMorpho env opts) .
+                    concatMap words $ toStrings ts
+               _ -> return . fromString . unlines .
+                    map prMorphoAnalysis . concatMap (morphos env opts) .
+                    concatMap words $ toStrings ts,
      flags = [
        ("lang","the languages of analysis (comma-separated, no spaces)")
        ],
@@ -306,16 +335,18 @@ pgfCommands = Map.fromList [
      longname = "morpho_quiz",
      synopsis = "start a morphology quiz",
      syntax   = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
-     exec = needPGF $ \ opts arg pgf -> do
-         lang <- optLang pgf opts
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
+         let lang = optLang pgf opts
          let typ  = optType pgf opts
+         pgf <- optProbs opts pgf
          let mt = mexp (toExprs arg)
          restricted $ morphologyQuiz mt pgf lang typ
          return void,
      flags = [
        ("lang","language of the quiz"),
        ("cat","category of the quiz"),
-       ("number","maximum number of questions")
+       ("number","maximum number of questions"),
+       ("probs","file with biased probabilities for generation")
        ]
      }),
 
@@ -326,25 +357,24 @@ pgfCommands = Map.fromList [
        "Shows all trees returned by parsing a string in the grammars in scope.",
        "The -lang flag can be used to restrict this to fewer languages.",
        "The default start category can be overridden by the -cat flag.",
-       "See also the ps command for lexing and character encoding."
-       ],
-     exec = needPGF $ \opts ts pgf ->
-              return $
-                foldr (joinPiped . fromParse1 opts) void 
-                  (concat [
-                              [(s,parse concr (optType pgf opts) s) |
-                                            concr <- optLangs pgf opts] 
-                           | s <- toStrings ts]),
-     options = [
-       ("show_probs", "show the probability of each result")
+       "See also the ps command for lexing and character encoding.",
+       "",
+       "The -openclass flag is experimental and allows some robustness in ",
+       "the parser. For example if -openclass=\"A,N,V\" is given, the parser",
+       "will accept unknown adjectives, nouns and verbs with the resource grammar."
        ],
+     exec = getEnv $ \ opts ts (Env pgf mos) ->
+              return $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
      flags = [
        ("cat","target category of parsing"),
        ("lang","the languages of parsing (comma-separated, no spaces)"),
-       ("number","limit the results to the top N trees")
+       ("openclass","list of open-class categories for robust parsing"),
+       ("depth","maximal depth for proof search if the abstract syntax tree has meta variables")
+       ],
+     options = [
+       ("bracket","prints the bracketed string from the parser")
        ]
      }),
-
   ("pg", emptyCommandInfo { -----
      longname = "print_grammar",
      synopsis = "print the actual grammar with the given printer",
@@ -364,8 +394,9 @@ pgfCommands = Map.fromList [
         " " ++ opt ++ "\t\t" ++ expl |
            ((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
        ]),
-     exec  = needPGF $ \opts _ pgf -> prGrammar pgf opts,
+     exec  = getEnv $ \opts _ env -> prGrammar env opts,
      flags = [
+       --"cat",
        ("file",   "set the file name when printing with -pgf option"),
        ("lang",   "select languages for the some options (default all languages)"),
        ("printer","select the printing format (see flag values above)")
@@ -385,7 +416,6 @@ pgfCommands = Map.fromList [
        mkEx ("pg -funs | ? grep \" S ;\"  -- show functions with value cat S")
        ]
      }),
-
   ("pt", emptyCommandInfo {
      longname = "put_tree",
      syntax = "pt OPT? TREE",
@@ -399,12 +429,11 @@ pgfCommands = Map.fromList [
      examples = [
        mkEx "pt -compute (plus one two)                               -- compute value"
        ],
-     exec = needPGF $ \opts arg pgf ->
-            returnFromExprs False .  takeOptNum opts . map (flip (,) 0) . treeOps pgf opts $ toExprs arg,
+     exec = getEnv $ \ opts arg (Env pgf mos) ->
+            returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg,
      options = treeOpOptions undefined{-pgf-},
      flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
      }),
-
   ("rf",  emptyCommandInfo {
      longname = "read_file",
      synopsis = "read string or tree input from a file",
@@ -417,9 +446,10 @@ pgfCommands = Map.fromList [
        ],
      options = [
        ("lines","return the list of lines, instead of the singleton of all contents"),
+       ("paragraphs","return the list of paragraphs, as separated by empty lines"),
        ("tree","convert strings into trees")
        ],
-     exec = needPGF $ \ opts _ pgf -> do
+     exec = getEnv $ \ opts _ (Env pgf mos) -> do
        let file = valStrOpts "file" "_gftmp" opts
        let exprs []         = ([],empty)
            exprs ((n,s):ls) | null s
@@ -428,12 +458,12 @@ pgfCommands = Map.fromList [
                                 Just e  -> let (es,err) = exprs ls
                                            in case inferExpr pgf e of
                                                 Right (e,t) -> (e:es,err)
-                                                Left err    -> (es,"on line" <+> n <> ':' $$ nest 2 err $$ err)
+                                                Left tcerr  -> (es,"on line" <+> n <> ':' $$ nest 2 (ppTcError tcerr) $$ err)
                                 Nothing -> let (es,err) = exprs ls
                                            in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
            returnFromLines ls = case exprs ls of
                                   (es, err) | null es   -> return $ pipeMessage $ render (err $$ "no trees found")
-                                            | otherwise -> return $ pipeWithMessage (map (flip (,) 0) es) (render err)
+                                            | otherwise -> return $ pipeWithMessage es (render err)
 
        s <- restricted $ readFile file
        case opts of
@@ -442,26 +472,56 @@ pgfCommands = Map.fromList [
          _ | isOpt "tree" opts ->
                returnFromLines [(1::Int,s)]
          _ | isOpt "lines" opts -> return (fromStrings $ lines s)
+         _ | isOpt "paragraphs" opts -> return (fromStrings $ toParagraphs $ lines s)
          _ -> return (fromString s),
      flags = [("file","the input file name")]
      }),
-
+  ("rt", emptyCommandInfo {
+     longname = "rank_trees",
+     synopsis = "show trees in an order of decreasing probability",
+     explanation = unlines [
+       "Order trees from the most to the least probable, using either",
+       "even distribution in each category (default) or biased as specified",
+       "by the file given by flag -probs=FILE, where each line has the form",
+       "'function probability', e.g. 'youPol_Pron  0.01'."
+       ],
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
+         let ts = toExprs arg
+         pgf <- optProbs opts pgf
+         let tds = rankTreesByProbs pgf ts
+         if isOpt "v" opts
+           then putStrLn $
+                  unlines [showExpr []  t ++ "\t--" ++ show d | (t,d) <- tds]
+           else return ()
+         returnFromExprs $ map fst tds,
+     flags = [
+       ("probs","probabilities from this file (format 'f 0.6' per line)")
+       ],
+     options = [
+       ("v","show all trees with their probability scores")
+       ],
+     examples = [
+      mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result"
+      ]
+     }),
   ("tq", emptyCommandInfo {
      longname = "translation_quiz",
      syntax   = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
      synopsis = "start a translation quiz",
-     exec = needPGF $ \ opts arg pgf -> do
-         from <- optLangFlag "from" pgf opts
-         to   <- optLangFlag "to"   pgf opts
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
+         let from = optLangFlag "from" pgf opts
+         let to   = optLangFlag "to" pgf opts
          let typ  = optType pgf opts
          let mt   = mexp (toExprs arg)
+         pgf <- optProbs opts pgf
          restricted $ translationQuiz mt pgf from to typ
          return void,
      flags = [
        ("from","translate from this language"),
        ("to","translate to this language"),
        ("cat","translate in this category"),
-       ("number","the maximum number of questions")
+       ("number","the maximum number of questions"),
+       ("probs","file with biased probabilities for generation")
        ],
      examples = [
        mkEx ("tq -from=Eng -to=Swe                               -- any trees in startcat"),
@@ -469,6 +529,7 @@ pgfCommands = Map.fromList [
        ]
      }),
 
+
   ("vd", emptyCommandInfo {
      longname = "visualize_dependency",
      synopsis = "show word dependency tree graphically",
@@ -486,7 +547,7 @@ pgfCommands = Map.fromList [
        "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
        "See also 'vp -showdep' for another visualization of dependencies." 
        ],
-     exec = needPGF $ \ opts arg pgf -> do
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
          let absname = abstractName pgf
          let es = toExprs arg
          let debug = isOpt "v" opts
@@ -499,8 +560,8 @@ pgfCommands = Map.fromList [
          mclab <- case cnclabels of
            "" -> return Nothing
            _  -> (Just . getCncDepLabels) `fmap` restricted (readFile cnclabels)
-         concr <- optLang pgf opts
-         let grphs = map (graphvizDependencyTree outp debug mlab mclab concr) es
+         let lang = optLang pgf opts
+         let grphs = map (graphvizDependencyTree outp debug mlab mclab pgf lang) es
          if isOpt "conll2latex" opts
            then return $ fromString $ conlls2latexDoc $ stanzas $ unlines $ toStrings arg
            else if isFlag "view" opts && valStrOpts "output" "" opts == "latex"
@@ -535,6 +596,7 @@ pgfCommands = Map.fromList [
        ]
     }),
 
+
   ("vp", emptyCommandInfo {
      longname = "visualize_parse",
      synopsis = "show parse tree graphically",
@@ -546,8 +608,9 @@ pgfCommands = Map.fromList [
        "by the view flag. The target format is png, unless overridden by the",
        "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)."
        ],
-     exec = needPGF $ \opts arg pgf -> do
-         let es        = toExprs arg
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
+         let es = toExprs arg
+         let lang = optLang pgf opts
          let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
                                           noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
                                           noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
@@ -560,11 +623,10 @@ pgfCommands = Map.fromList [
                                           leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
                                          }
          let depfile = valStrOpts "file" "" opts
-         concr  <- optLang pgf opts
          mlab <- case depfile of
            "" -> return Nothing
            _  -> (Just . getDepLabels) `fmap` restricted (readFile depfile)
-         let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es
+         let grphs = map (graphvizParseTreeDep mlab pgf lang gvOptions) es
          if isFlag "view" opts || isFlag "format" opts
            then do
              let view = optViewGraph opts
@@ -599,6 +661,7 @@ pgfCommands = Map.fromList [
        ]
     }),
 
+
   ("vt", emptyCommandInfo {
      longname = "visualize_tree",
      synopsis = "show a set of trees graphically",
@@ -611,7 +674,7 @@ pgfCommands = Map.fromList [
        "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
        "With option -mk, use for showing library style function names of form 'mkC'."
        ],
-     exec = needPGF $ \opts arg pgf ->
+     exec = getEnv $ \ opts arg (Env pgf mos) ->
       let es = toExprs arg in
        if isOpt "mk" opts
        then return $ fromString $ unlines $ map (tree2mk pgf) es
@@ -623,7 +686,7 @@ pgfCommands = Map.fromList [
        else do
          let funs = not (isOpt "nofun" opts)
          let cats = not (isOpt "nocat" opts)
-         let grphs = map (graphvizAbstractTree pgf (graphvizDefaults{noFun=funs,noCat=cats})) es
+         let grphs = map (graphvizAbstractTree pgf (funs,cats)) es
          if isFlag "view" opts || isFlag "format" opts
            then do
              let view = optViewGraph opts
@@ -645,7 +708,6 @@ pgfCommands = Map.fromList [
        ("view","program to open the resulting file (default \"open\")")
        ]
      }),
-
   ("ai", emptyCommandInfo {
      longname = "abstract_info",
      syntax = "ai IDENTIFIER  or  ai EXPR",
@@ -658,156 +720,205 @@ pgfCommands = Map.fromList [
        "If a whole expression is given it prints the expression with refined",
        "metavariables and the type of the expression."
        ],
-     exec = needPGF $ \opts arg pgf -> do
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
        case toExprs arg of
-         [e] -> case unApp e of
-                  Just (id, []) -> case functionType pgf id of
-                                     Just ty -> do putStrLn (showFun pgf id ty)
-                                                   putStrLn ("Probability: "++show (treeProbability pgf e))
-                                                   return void
-                                     Nothing -> case categoryContext pgf id of
-                                                  Just hypos -> do putStrLn ("cat "++id++if null hypos then "" else ' ':showContext [] hypos)
-                                                                   let ls = [showFun pgf fn ty | fn <- functionsByCat pgf id, Just ty <- [functionType pgf fn]]
-                                                                   if null ls
-                                                                     then return ()
-                                                                     else putStrLn (unlines ("":ls))
-                                                                   putStrLn ("Probability: "++show (categoryProbability pgf id))
-                                                                   return void
-                                                  Nothing    -> do putStrLn ("unknown category of function identifier "++show id)
-                                                                   return void
-                  _             -> case inferExpr pgf e of
-                                     Left err     -> error err
-                                     Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
-                                                        putStrLn ("Type:        "++showType [] ty)
-                                                        putStrLn ("Probability: "++show (treeProbability pgf e))
-                                                        return void
+         [EFun id] -> case Map.lookup id (funs (abstract pgf)) of
+                        Just fd -> do putStrLn $ render (ppFun id fd)
+                                      let (_,_,_,prob) = fd
+                                      putStrLn ("Probability: "++show prob)
+                                      return void
+                        Nothing -> case Map.lookup id (cats (abstract pgf)) of
+                                     Just cd   -> do putStrLn $
+                                                        render (ppCat id cd $$
+                                                                if null (functionsToCat pgf id)
+                                                                  then empty
+                                                                  else ' ' $$
+                                                                       vcat [ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- functionsToCat pgf id] $$
+                                                                       ' ')
+                                                     let (_,_,prob) = cd
+                                                     putStrLn ("Probability: "++show prob)
+                                                     return void
+                                     Nothing   -> do putStrLn ("unknown category of function identifier "++show id)
+                                                     return void
+         [e]         -> case inferExpr pgf e of
+                          Left tcErr   -> error $ render (ppTcError tcErr)
+                          Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
+                                             putStrLn ("Type:        "++showType [] ty)
+                                             putStrLn ("Probability: "++show (probTree pgf e))
+                                             return void
          _           -> do putStrLn "a single identifier or expression is expected from the command"
                            return void,
      needsTypeCheck = False
      })
   ]
  where
-   needPGF exec opts ts = do
-     mb_pgf <- getPGF
-     case mb_pgf of
-       Just pgf -> liftSIO $ exec opts ts pgf
-       _ -> fail "Import a grammar before using this command"
+   getEnv exec opts ts = liftSIO . exec opts ts =<< getPGFEnv
+
+   par pgf opts s = case optOpenTypes opts of
+                  []        -> [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
+                  open_typs -> [parseWithRecovery pgf lang (optType pgf opts) open_typs (Just dp) s | lang <- optLangs pgf opts]
+     where
+       dp = valIntOpts "depth" 4 opts
+
+   fromParse opts = foldr (joinPiped . fromParse1 opts) void
 
    joinPiped (Piped (es1,ms1)) (Piped (es2,ms2)) = Piped (jA es1 es2,ms1+++-ms2)
      where
        jA (Exprs es1) (Exprs es2) = Exprs (es1++es2)
+       -- ^ fromParse1 always output Exprs
 
-   fromParse1 opts (s,po) =
-     case po of
-       ParseOk ts      -> fromExprs (isOpt "show_probs" opts) (takeOptNum opts ts)
-       ParseFailed i t -> pipeMessage $ "The parser failed at token "
-                                        ++ show i ++": "
-                                        ++ show t
-       ParseIncomplete -> pipeMessage "The sentence is not complete"
+   fromParse1 opts (s,(po,bs))
+     | isOpt "bracket" opts = pipeMessage (showBracketedString bs)
+     | otherwise            =
+         case po of
+           ParseOk ts      -> fromExprs ts
+           ParseFailed i   -> pipeMessage $ "The parser failed at token "
+                                             ++ show i ++": "
+                                             ++ show (words s !! max 0 (i-1))
+                                          -- ++ " in " ++ show s
+           ParseIncomplete -> pipeMessage "The sentence is not complete"
+           TypeError errs  ->
+             pipeMessage . render $
+               "The parsing is successful but the type checking failed with error(s):"
+               $$ nest 2 (vcat (map (ppTcError . snd) errs))
 
-   optLins pgf opts ts = concatMap (optLin pgf opts) ts
+   optLins pgf opts ts = case opts of
+     _ | isOpt "groups" opts ->
+       concatMap snd $ groupResults
+         [[(lang, s) | lang <- optLangs pgf opts,s <- linear pgf opts lang t] | t <- ts]
+     _ -> concatMap (optLin pgf opts) ts
    optLin pgf opts t =
      case opts of
        _ | isOpt "treebank" opts && isOpt "chunks" opts ->
-         (abstractName pgf ++ ": " ++ showExpr [] t) :
-         [lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts]
+         (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
+         [showCId lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts]
        _ | isOpt "treebank" opts ->
-         (abstractName pgf ++ ": " ++ showExpr [] t) :
-         [concreteName concr ++ ": " ++ s | concr <- optLangs pgf opts, s<-linear opts concr t]
+         (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
+         [showCId lang ++ ": " ++ s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
+       _ | isOpt "tabtreebank" opts ->
+         return $ concat $ intersperse "\t" $ (showExpr [] t) :
+                   [s | lang <- optLangs pgf opts, s <- linear pgf opts lang t]
        _ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t   
-       _ -> [s | concr <- optLangs pgf opts, s <- linear opts concr t]
+       _ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
    linChunks pgf opts t = 
-     [(concreteName concr, unwords (intersperse "<+>" (map (unlines . linear opts concr) (treeChunks t)))) | concr <- optLangs pgf opts]
+     [(lang, unwords (intersperse "<+>" (map (unlines . linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts]
 
-   linear :: [Option] -> Concr -> Expr -> [String]
-   linear opts concr = case opts of
-       _ | isOpt "all"     opts -> concat .
-                                   map (map snd) . tabularLinearizeAll concr
+   linear :: PGF -> [Option] -> CId -> Expr -> [String]
+   linear pgf opts lang = let unl = unlex opts lang in case opts of
+       _ | isOpt "all"     opts -> concat . -- intersperse [[]] .
+                                   map (map (unl . snd)) . tabularLinearizes pgf lang
        _ | isOpt "list"    opts -> (:[]) . commaList . concat .
-                                   map (map snd) . tabularLinearizeAll concr
-       _ | isOpt "table"   opts -> concat .
-                                    map (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
-       _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
-       _                        -> (:[]) . linearize concr
+                                   map (map (unl . snd)) . tabularLinearizes pgf lang
+       _ | isOpt "table"   opts -> concat . -- intersperse [[]] .
+                    map (map (\(p,v) -> p+++":"+++unl v)) . tabularLinearizes pgf lang
+       _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize pgf lang
+       _                        -> (:[]) . unl . linearize pgf lang
 
    -- replace each non-atomic constructor with mkC, where C is the val cat
    tree2mk pgf = showExpr [] . t2m where
      t2m t = case unApp t of
-               Just (cid,ts@(_:_)) -> mkApp (mk cid) (map t2m ts)
-               _                   -> t
-     mk f = case functionType pgf f of
-              Just ty -> let (_,cat,_) = unType ty
-                         in "mk" ++ cat
-              Nothing -> f
+       Just (cid,ts@(_:_)) -> mkApp (mk cid) (map t2m ts)
+       _ -> t
+     mk = mkCId . ("mk" ++) . showCId . lookValCat (abstract pgf)
+
+   unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
+
+   getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
+     lexs -> case lookup lang
+               [(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
+       Just le -> chunks ',' le
+       _ -> []
 
    commaList [] = []
    commaList ws = concat $ head ws : map (", " ++) (tail ws)
 
+-- Proposed logic of coding in unlexing:
+--   - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used.
+--   - If lang has flag coding=utf8, -to_utf8 is ignored.
+--   - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first.
+-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
+{-
+   unlexx pgf opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ----
+     optsC = case lookConcrFlag pgf (mkCId lang) (mkCId "coding") of
+       Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts
+       Just (LStr other) | isOpt "to_utf8" opts ->
+                      let cod = ("from_" ++ other)
+                      in cod : filter (/=cod) (map prOpt opts)
+       _ -> map prOpt opts
+-}
+   optRestricted opts pgf =
+     restrictPGF (\f -> and [hasLin pgf la f | la <- optLangs pgf opts]) pgf
+
    optLang  = optLangFlag "lang"
    optLangs = optLangsFlag "lang"
 
-   optLangFlag flag pgf opts =
-     case optLangsFlag flag pgf opts of
-       []     -> fail "no language specified"
-       (l:ls) -> return l
+   optLangsFlag f pgf opts = case valStrOpts f "" opts of
+     "" -> languages pgf
+     lang -> map (completeLang pgf) (chunks ',' lang)
+   completeLang pgf la = let cla = (mkCId la) in
+     if elem cla (languages pgf)
+       then cla
+       else (mkCId (showCId (abstractName pgf) ++ la))
 
-   optLangsFlag flag pgf opts =
-     case valStrOpts flag "" opts of
-       ""  -> Map.elems langs
-       str -> mapMaybe (completeLang pgf) (chunks ',' str)
-     where
-       langs = languages pgf
+   optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [wildCId]
 
-       completeLang pgf la =
-         mplus (Map.lookup la                       langs)
-               (Map.lookup (abstractName pgf ++ la) langs)
+   optOpenTypes opts = case valStrOpts "openclass" "" opts of
+     ""   -> []
+     cats -> mapMaybe readType (chunks ',' cats)
+
+   optProbs opts pgf = case valStrOpts "probs" "" opts of
+     ""   -> return pgf
+     file -> do
+       probs <- restricted $ readProbabilitiesFromFile file pgf
+       return (setProbabilities probs pgf)
 
    optFile opts = valStrOpts "file" "_gftmp" opts
 
    optType pgf opts =
-     let readOpt str = case readType str of
-                         Just ty -> case checkType pgf ty of
-                                      Left err -> error err
-                                      Right ty -> ty
-                         Nothing -> error ("Can't parse '"++str++"' as a type")
-     in maybeStrOpts "cat" (startCat pgf) readOpt opts
+     let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
+     in case readType str of
+          Just ty -> case checkType pgf ty of
+                       Left tcErr -> error $ render (ppTcError tcErr)
+                       Right ty   -> ty
+          Nothing -> error ("Can't parse '"++str++"' as a type")
    optViewFormat opts = valStrOpts "format" "png" opts
    optViewGraph opts = valStrOpts "view" "open" opts
    optNum opts = valIntOpts "number" 1 opts
    optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
    takeOptNum opts = take (optNumInf opts)
 
-   returnFromExprs show_p es =
-     return $ 
-       case es of
-         [] -> pipeMessage "no trees found"
-         _  -> fromExprs show_p es
+   returnFromExprs es = return $ case es of
+     [] -> pipeMessage "no trees found"
+     _  -> fromExprs es
 
-   prGrammar pgf opts
+   prGrammar (Env pgf mos) opts
      | isOpt "pgf"      opts = do
-          let outfile = valStrOpts "file" (abstractName pgf ++ ".pgf") opts
-          restricted $ writePGF outfile pgf
+          let pgf1 = if isOpt "opt" opts then optimizePGF pgf else pgf
+          let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts
+          restricted $ encodeFile outfile pgf1
           putStrLn $ "wrote file " ++ outfile
           return void
-     | isOpt "cats"     opts = return $ fromString $ unwords $ categories pgf
-     | isOpt "funs"     opts = return $ fromString $ unlines [showFun pgf f ty | f <- functions pgf, Just ty <- [functionType pgf f]]
-     | isOpt "fullform" opts = return $ fromString $ concatMap prFullFormLexicon $ optLangs pgf opts
-     | isOpt "langs"    opts = return $ fromString $ unwords $ Map.keys $ languages pgf
+     | isOpt "cats"     opts = return $ fromString $ unwords $ map showCId $ categories pgf
+     | isOpt "funs"     opts = return $ fromString $ unlines $ map showFun $ funsigs pgf
+     | isOpt "fullform" opts = return $ fromString $ concatMap (morpho mos "" prFullFormLexicon) $ optLangs pgf opts
+     | isOpt "langs"    opts = return $ fromString $ unwords $ map showCId $ languages pgf
 
-     | isOpt "lexc"     opts = return $ fromString $ concatMap prLexcLexicon $ optLangs pgf opts
-     | isOpt "missing"  opts = return $ fromString $ unlines $ [unwords (concreteName concr:":":[f | f <- functions pgf, not (hasLinearization concr f)]) |
-                                                                  concr <- optLangs pgf opts]
-     | isOpt "words" opts = return $ fromString $ concatMap prAllWords $ optLangs pgf opts
+     | isOpt "lexc"     opts = return $ fromString $ concatMap (morpho mos "" prLexcLexicon) $ optLangs pgf opts
+     | isOpt "missing"  opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) |
+                                                                  la <- optLangs pgf opts, let cs = missingLins pgf la]
+     | isOpt "words" opts = return $ fromString $ concatMap (morpho mos "" prAllWords) $ optLangs pgf opts
      | otherwise             = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
                                   return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
 
-   showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
-                       where
-                         kwd | functionIsDataCon pgf id = "data"
-                             | otherwise                = "fun"
+   funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
+   showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
 
-   morphos pgf opts s =
-     [(s,lookupMorpho concr s) | concr <- optLangs pgf opts]
+   morphos (Env pgf mos) opts s =
+     [(s,morpho mos [] (\mo -> lookupMorpho mo s) la) | la <- optLangs pgf opts]
+
+   morpho mos z f la = maybe z f $ Map.lookup la mos
+
+   optMorpho (Env pgf mos) opts = morpho mos (error "no morpho") id (head (optLangs pgf opts))
 
    optClitics opts = case valStrOpts "clitics" "" opts of
      "" -> []
@@ -820,28 +931,18 @@ pgfCommands = Map.fromList [
    -- ps -f -g s returns g (f s)
    treeOps pgf opts s = foldr app s (reverse opts) where
      app (OOpt  op)         | Just (Left  f) <- treeOp pgf op = f
-     app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f x
+     app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (mkCId x)
      app _                                                    = id
 
-morphoMissing  :: Concr -> [String] -> [String]
-morphoMissing = morphoClassify False
-
-morphoKnown    :: Concr -> [String] -> [String]
-morphoKnown = morphoClassify True
-
-morphoClassify :: Bool -> Concr -> [String] -> [String]
-morphoClassify k concr ws = [w | w <- ws, k /= null (lookupMorpho concr w), notLiteral w] where
-  notLiteral w = not (all isDigit w)
-
 treeOpOptions pgf = [(op,expl) | (op,(expl,Left  _)) <- allTreeOps pgf]
 treeOpFlags   pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
 
-translationQuiz :: Maybe Expr -> PGF -> Concr -> Concr -> Type -> IO ()
+translationQuiz :: Maybe Expr -> PGF -> Language -> Language -> Type -> IO ()
 translationQuiz mex pgf ig og typ = do
   tts <- translationList mex pgf ig og typ infinity
   mkQuiz "Welcome to GF Translation Quiz." tts
 
-morphologyQuiz :: Maybe Expr -> PGF -> Concr -> Type -> IO ()
+morphologyQuiz :: Maybe Expr -> PGF -> Language -> Type -> IO ()
 morphologyQuiz mex pgf ig typ = do
   tts <- morphologyList mex pgf ig typ infinity
   mkQuiz "Welcome to GF Morphology Quiz." tts
@@ -850,28 +951,30 @@ morphologyQuiz mex pgf ig typ = do
 infinity :: Int
 infinity = 256
 
-prLexcLexicon :: Concr -> String
-prLexcLexicon concr =
-  unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w  ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"]
+prLexcLexicon :: Morpho -> String
+prLexcLexicon mo =
+  unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w  ++ " # ;" | (w,lps) <- morpho, (l,p) <- lps] ++ ["END"]
  where
-  morpho = fullFormLexicon concr
-  prLexc l p = l ++ concat (mkTags (words p))
+  morpho = fullFormLexicon mo
+  prLexc l p = showCId l ++ concat (mkTags (words p))
   mkTags p = case p of
     "s":ws -> mkTags ws   --- remove record field
     ws -> map ('+':) ws
 
-  multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
+  multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p) <- lps]
+  -- thick_A+(AAdj+Posit+Gen):thick's # ;
 
-prFullFormLexicon :: Concr -> String
-prFullFormLexicon concr =
-  unlines (map prMorphoAnalysis (fullFormLexicon concr))
+prFullFormLexicon :: Morpho -> String
+prFullFormLexicon mo =
+  unlines (map prMorphoAnalysis (fullFormLexicon mo))
 
-prAllWords :: Concr -> String
-prAllWords concr =
-  unwords [w | (w,_) <- fullFormLexicon concr]
+prAllWords :: Morpho -> String
+prAllWords mo =
+  unwords [w | (w,_) <- fullFormLexicon mo]
 
+prMorphoAnalysis :: (String,[(Lemma,Analysis)]) -> String
 prMorphoAnalysis (w,lps) =
-  unlines (w:[l ++ " : " ++ p ++ show prob | (l,p,prob) <- lps])
+  unlines (w:[showCId l ++ " : " ++ p | (l,p) <- lps])
 
 viewGraphviz :: String -> String -> String -> [String] -> SIO CommandOutput
 viewGraphviz view format name grphs = do

src/compiler/GF/Command/Commands2.hs

@@ -0,0 +1,831 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+module GF.Command.Commands2 (
+  PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands,
+  options, flags,
+  ) where
+import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import PGF2
+import qualified PGF as H
+import GF.Compile.ToAPI(exprToAPI)
+import GF.Infra.UseIO(writeUTF8File)
+import GF.Infra.SIO(MonadSIO,liftSIO,putStrLn,restricted,restrictedSystem)
+import GF.Command.Abstract
+import GF.Command.CommandInfo
+import GF.Data.Operations
+import Data.List(intersperse,intersect,nub,sortBy)
+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}
+
+pgfEnv pgf = Env (Just pgf) (languages pgf)
+emptyPGFEnv = Env Nothing Map.empty
+
+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
+                      case pgf env of
+                        Just gr -> either fail
+                                          (return . hsExpr . fst)
+                                          (inferExpr gr (cExpr e))
+                        Nothing  -> fail "Import a grammar before using this command"
+
+pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
+pgfCommands = Map.fromList [
+  ("aw", emptyCommandInfo {
+     longname = "align_words",
+     synopsis = "show word alignments between languages graphically",
+     explanation = unlines [
+       "Prints a set of strings in the .dot format (the graphviz format).",
+       "The graph can be saved in a file by the wf command as usual.",
+       "If the -view flag is defined, the graph is saved in a temporary file",
+       "which is processed by graphviz and displayed by the program indicated",
+       "by the flag. The target format is postscript, unless overridden by the",
+       "flag -format."
+       ],
+     exec = needPGF $ \opts es env -> do
+         let cncs = optConcs env opts
+         if isOpt "giza" opts
+           then if length cncs == 2
+                  then let giz = map (gizaAlignment pgf (snd (cncs !! 0)) (snd (cncs !! 1)) . cExpr) (toExprs es)
+                           lsrc = unlines $ map (\(x,_,_) -> x) giz
+                           ltrg = unlines $ map (\(_,x,_) -> x) giz
+                           align = unlines $ map (\(_,_,x) -> x) giz
+                           grph = if null (toExprs es) then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align
+                       in return (fromString grph)
+                  else error "For giza alignment you need exactly two languages"
+           else let gvOptions=graphvizDefaults{leafFont = valStrOpts "font" "" opts,
+                                               leafColor = valStrOpts "color" "" opts,
+                                               leafEdgeStyle = valStrOpts "edgestyle" "" opts
+                                              }
+                    grph = if null (toExprs es) then [] else graphvizWordAlignment (map snd cncs) gvOptions (cExpr (head (toExprs es)))
+                in if isFlag "view" opts || isFlag "format" opts
+                     then do let file s = "_grph." ++ s
+                             let view = optViewGraph opts
+                             let format = optViewFormat opts
+                             restricted $ writeUTF8File (file "dot") grph
+                             restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+                             restrictedSystem $ view ++ " " ++ file format
+                             return void
+                     else return (fromString grph),
+     examples = [
+       ("gr | aw"                         , "generate a tree and show word alignment as graph script"),
+       ("gr | aw -view=\"open\""          , "generate a tree and display alignment on Mac"),
+       ("gr | aw -view=\"eog\""           , "generate a tree and display alignment on Ubuntu"),
+       ("gt | aw -giza | wf -file=aligns" , "generate trees, send giza alignments to file")
+       ],
+     options = [
+       ("giza",  "show alignments in the Giza format; the first two languages")
+       ],
+     flags = [
+       ("format","format of the visualization file (default \"png\")"),
+       ("lang",  "alignments for this list of languages (default: all)"),
+       ("view",  "program to open the resulting file"),
+       ("font",  "font for the words"),
+       ("color", "color for the words"),
+       ("edgestyle", "the style for links between words")
+       ]
+    }),
+{-
+  ("eb", emptyCommandInfo {
+     longname = "example_based",
+     syntax = "eb (-probs=FILE | -lang=LANG)* -file=FILE.gfe",
+     synopsis = "converts .gfe files to .gf files by parsing examples to trees",
+     explanation = unlines [
+       "Reads FILE.gfe and writes FILE.gf. Each expression of form",
+       "'%ex CAT QUOTEDSTRING' in FILE.gfe is replaced by a syntax tree.",
+       "This tree is the first one returned by the parser; a biased ranking",
+       "can be used to regulate the order. If there are more than one parses",
+       "the rest are shown in comments, with probabilities if the order is biased.",
+       "The probabilities flag and configuration file is similar to the commands",
+       "gr and rt. Notice that the command doesn't change the environment,",
+       "but the resulting .gf file must be imported separately."
+       ],
+     options = [
+       ("api","convert trees to overloaded API expressions (using Syntax not Lang)")
+       ],
+     flags = [
+       ("file","the file to be converted (suffix .gfe must be given)"),
+       ("lang","the language in which to parse"),
+       ("probs","file with probabilities to rank the parses")
+       ],
+     exec = \env@(pgf, mos) opts _ -> do
+       let file = optFile opts
+       pgf <- optProbs opts pgf
+       let printer = if (isOpt "api" opts) then exprToAPI else (H.showExpr [])
+       let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
+       (file',ws) <- restricted $ parseExamplesInGrammar conf file
+       if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
+       return (fromString ("wrote " ++ file')),
+     needsTypeCheck = False
+     }),
+-}
+{-
+  ("gr", emptyCommandInfo {
+     longname = "generate_random",
+     synopsis = "generate random trees in the current abstract syntax",
+     syntax = "gr [-cat=CAT] [-number=INT]",
+     examples = [
+       mkEx "gr                     -- one tree in the startcat of the current grammar",
+       mkEx "gr -cat=NP -number=16  -- 16 trees in the category NP",
+       mkEx "gr -lang=LangHin,LangTha -cat=Cl  -- Cl, both in LangHin and LangTha",
+       mkEx "gr -probs=FILE         -- generate with bias",
+       mkEx "gr (AdjCN ? (UseN ?))  -- generate trees of form (AdjCN ? (UseN ?))"
+       ],
+     explanation = unlines [
+       "Generates a list of random trees, by default one tree.",
+       "If a tree argument is given, the command completes the Tree with values to",
+       "all metavariables in the tree. The generation can be biased by probabilities,",
+       "given in a file in the -probs flag."
+       ],
+     flags = [
+       ("cat","generation category"),
+       ("lang","uses only functions that have linearizations in all these languages"),
+       ("number","number of trees generated"),
+       ("depth","the maximum generation depth"),
+       ("probs", "file with biased probabilities (format 'f 0.4' one by line)")
+       ],
+     exec = \env@(pgf, mos) opts xs -> do
+       pgf <- optProbs opts (optRestricted opts pgf)
+       gen <- newStdGen
+       let dp = valIntOpts "depth" 4 opts
+       let ts  = case mexp xs of
+                   Just ex -> H.generateRandomFromDepth gen pgf ex (Just dp)
+                   Nothing -> H.generateRandomDepth     gen pgf (optType pgf opts) (Just dp)
+       returnFromExprs $ take (optNum opts) ts
+     }),
+-}
+  ("gt", emptyCommandInfo {
+     longname = "generate_trees",
+     synopsis = "generates a list of trees, by default exhaustive",
+     flags = [("cat","the generation category"),
+              ("number","the number of trees generated")],
+     examples = [
+       mkEx "gt                     -- all trees in the startcat",
+       mkEx "gt -cat=NP -number=16  -- 16 trees in the category NP"],
+     exec = needPGF $ \ opts _ env@(pgf,_) ->
+            let ts = map fst (generateAll pgf cat)
+                cat = optType pgf opts
+            in returnFromCExprs (takeOptNum opts ts),
+     needsTypeCheck = False
+     }),
+  ("i", emptyCommandInfo {
+     longname = "import",
+     synopsis = "import a grammar from a compiled .pgf file",
+     explanation = unlines [
+       "Reads a grammar from a compiled .pgf file.",
+       "Old modules are discarded.",
+{-
+       "The grammar parser depends on the file name suffix:",
+
+       "  .cf    context-free (labelled BNF) source",
+       "  .ebnf  extended BNF source",
+       "  .gfm   multi-module GF source",
+       "  .gf    normal GF source",
+       "  .gfo   compiled GF source",
+-}
+       "  .pgf   precompiled grammar in Portable Grammar Format"
+       ],
+     flags = [
+--     ("probs","file with biased probabilities for generation")
+       ],
+     options = [
+       -- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
+--     ("retain","retain operations (used for cc command)"),
+--     ("src",   "force compilation from source"),
+--     ("v",     "be verbose - show intermediate status information")
+       ],
+     needsTypeCheck = False
+     }),
+  ("l", emptyCommandInfo {
+     longname = "linearize",
+     synopsis = "convert an abstract syntax expression to string",
+     explanation = unlines [
+       "Shows the linearization of a Tree by the grammars in scope.",
+       "The -lang flag can be used to restrict this to fewer languages.",
+       "A sequence of string operations (see command ps) can be given",
+       "as options, and works then like a pipe to the ps command, except",
+       "that it only affect the strings, not e.g. the table labels.",
+       "These can be given separately to each language with the unlexer flag",
+       "whose results are prepended to the other lexer flags. The value of the",
+       "unlexer flag is a space-separated list of comma-separated string operation",
+       "sequences; see example."
+       ],
+     examples = [
+       mkEx "l -lang=LangSwe,LangNor no_Utt   -- linearize a tree to LangSwe and LangNor",
+       mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
+       mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
+       ],
+     exec = needPGF $ \ opts arg env ->
+                      return . fromStrings . optLins env opts . map cExpr $ toExprs arg,
+     options = [
+       ("all",    "show all forms and variants, one by line (cf. l -list)"),
+       ("bracket","show tree structure with brackets and paths to nodes"),
+       ("groups", "all languages, grouped by lang, remove duplicate strings"),
+       ("list","show all forms and variants, comma-separated on one line (cf. l -all)"),
+       ("multi","linearize to all languages (default)"),
+       ("table","show all forms labelled by parameters"),
+       ("treebank","show the tree and tag linearizations with language names")
+       ],
+     flags = [
+       ("lang","the languages of linearization (comma-separated, no spaces)")
+       ]
+     }),
+  ("ma", emptyCommandInfo {
+     longname = "morpho_analyse",
+     synopsis = "print the morphological analyses of the (multiword) expression in the string",
+     explanation = unlines [
+       "Prints all the analyses of the (multiword) expression in the input string,",
+       "using the morphological analyser of the actual grammar (see command pg)"
+       ],
+     exec  = needPGF $ \opts args env -> 
+               return ((fromString . unlines .
+                        map prMorphoAnalysis . concatMap (morphos env opts) . toStrings) args),
+     flags = [
+       ("lang","the languages of analysis (comma-separated, no spaces)")
+       ]
+     }),
+{-
+  ("mq", emptyCommandInfo {
+     longname = "morpho_quiz",
+     synopsis = "start a morphology quiz",
+     syntax   = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
+     exec = \env@(pgf, mos) opts xs -> do
+         let lang = optLang pgf opts
+         let typ  = optType pgf opts
+         pgf <- optProbs opts pgf
+         let mt = mexp xs
+         restricted $ morphologyQuiz mt pgf lang typ
+         return void,
+     flags = [
+       ("lang","language of the quiz"),
+       ("cat","category of the quiz"),
+       ("number","maximum number of questions"),
+       ("probs","file with biased probabilities for generation")
+       ]
+     }),
+-}
+  ("p", emptyCommandInfo {
+     longname = "parse",
+     synopsis = "parse a string to abstract syntax expression",
+     explanation = unlines [
+       "Shows all trees returned by parsing a string in the grammars in scope.",
+       "The -lang flag can be used to restrict this to fewer languages.",
+       "The default start category can be overridden by the -cat flag.",
+       "See also the ps command for lexing and character encoding."
+       ],
+     flags = [
+       ("cat","target category of parsing"),
+       ("lang","the languages of parsing (comma-separated, no spaces)"),
+       ("number","maximum number of trees returned")
+       ],
+     examples = [
+         mkEx "p  \"this fish is fresh\" | l -lang=Swe  -- try parsing with all languages and translate the successful parses to Swedish"
+       ],
+     exec = needPGF $ \ opts ts env -> return . cParse env opts $ toStrings ts
+     }),
+  ("pg", emptyCommandInfo {
+     longname = "print_grammar",
+     synopsis = "prints different information about the grammar",
+     exec  = needPGF $ \opts _ env -> prGrammar env opts,
+     options = [
+       ("cats",   "show just the names of abstract syntax categories"),
+       ("fullform", "print the fullform lexicon"),
+       ("funs",   "show just the names and types of abstract syntax functions"),
+       ("langs",  "show just the names of top concrete syntax modules"),
+       ("lexc", "print the lexicon in Xerox LEXC format"),
+       ("missing","show just the names of functions that have no linearization"),
+       ("words", "print the list of words")
+       ],
+     flags = [
+       ("lang","the languages that need to be printed")
+       ],
+     examples = [
+       mkEx "pg -langs -- show the names of top concrete syntax modules",
+       mkEx "pg -funs | ? grep \" S ;\"  -- show functions with value cat S"
+       ]
+     }),
+
+{-
+  ("pt", emptyCommandInfo {
+     longname = "put_tree",
+     syntax = "pt OPT? TREE",
+     synopsis = "return a tree, possibly processed with a function",
+     explanation = unlines [
+       "Returns a tree obtained from its argument tree by applying",
+       "tree processing functions in the order given in the command line",
+       "option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors",
+       "are type checking and semantic computation."
+       ],
+     examples = [
+       mkEx "pt -compute (plus one two)                               -- compute value",
+       mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..."
+       ],
+     exec = \env@(pgf, mos) opts ->
+            returnFromExprs . takeOptNum opts . treeOps pgf opts,
+     options = treeOpOptions undefined{-pgf-},
+     flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
+     }),
+-}
+  ("rf",  emptyCommandInfo {
+     longname = "read_file",
+     synopsis = "read string or tree input from a file",
+     explanation = unlines [
+       "Reads input from file. The filename must be in double quotes.",
+       "The input is interpreted as a string by default, and can hence be",
+       "piped e.g. to the parse command. The option -tree interprets the",
+       "input as a tree, which can be given e.g. to the linearize command.",
+       "The option -lines will result in a list of strings or trees, one by line."
+       ],
+     options = [
+       ("lines","return the list of lines, instead of the singleton of all contents"),
+       ("tree","convert strings into trees")
+       ],
+     exec = needPGF $ \opts _ env@(pgf, mos) -> do
+       let file = optFile opts
+       let exprs []         = ([],empty)
+           exprs ((n,s):ls) | null s
+                            = exprs ls
+           exprs ((n,s):ls) = case readExpr s of
+                                Just e  -> let (es,err) = exprs ls
+                                           in case inferExpr pgf e of
+                                                Right (e,t) -> (e:es,err)
+                                                Left msg    -> (es,"on line" <+> n <> ':' $$ msg $$ err)
+                                Nothing -> let (es,err) = exprs ls
+                                           in (es,"on line" <+> n <> ':' <+> "parse error" $$ err)
+           returnFromLines ls = case exprs ls of
+                                  (es, err) | null es   -> return $ pipeMessage $ render (err $$ "no trees found")
+                                            | otherwise -> return $ pipeWithMessage (map hsExpr es) (render err)
+
+       s <- restricted $ readFile file
+       case opts of
+         _ | isOpt "lines" opts && isOpt "tree" opts ->
+               returnFromLines (zip [1::Int ..] (lines s))
+         _ | isOpt "tree" opts ->
+               returnFromLines [(1::Int,s)]
+         _ | isOpt "lines" opts -> return (fromStrings $ lines s)
+         _ -> return (fromString s),
+     flags = [("file","the input file name")]
+     }),
+  ("rt", emptyCommandInfo {
+     longname = "rank_trees",
+     synopsis = "show trees in an order of decreasing probability",
+     explanation = unlines [
+       "Order trees from the most to the least probable, using either",
+       "even distribution in each category (default) or biased as specified",
+       "by the file given by flag -probs=FILE, where each line has the form",
+       "'function probability', e.g. 'youPol_Pron  0.01'."
+       ],
+     exec = needPGF $ \opts es env@(pgf, _) -> do
+         let tds = sortBy (\(_,p) (_,q) -> compare p q)
+                          [(t, treeProbability pgf t) | t <- map cExpr (toExprs es)]
+         if isOpt "v" opts
+           then putStrLn $
+                  unlines [PGF2.showExpr []  t ++ "\t--" ++ show d | (t,d) <- tds]
+           else return ()
+         returnFromExprs $ map (hsExpr . fst) tds,
+     flags = [
+       ("probs","probabilities from this file (format 'f 0.6' per line)")
+       ],
+     options = [
+       ("v","show all trees with their probability scores")
+       ],
+     examples = [
+      mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result"
+      ]
+     }),
+{-
+  ("tq", emptyCommandInfo {
+     longname = "translation_quiz",
+     syntax   = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
+     synopsis = "start a translation quiz",
+     exec = \env@(pgf, mos) opts xs -> do
+         let from = optLangFlag "from" pgf opts
+         let to   = optLangFlag "to" pgf opts
+         let typ  = optType pgf opts
+         let mt   = mexp xs
+         pgf <- optProbs opts pgf
+         restricted $ translationQuiz mt pgf from to typ
+         return void,
+     flags = [
+       ("from","translate from this language"),
+       ("to","translate to this language"),
+       ("cat","translate in this category"),
+       ("number","the maximum number of questions"),
+       ("probs","file with biased probabilities for generation")
+       ],
+     examples = [
+       mkEx ("tq -from=Eng -to=Swe                               -- any trees in startcat"),
+       mkEx ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?))  -- only trees of this form")
+       ]
+     }),
+  ("vd", emptyCommandInfo {
+     longname = "visualize_dependency",
+     synopsis = "show word dependency tree graphically",
+     explanation = unlines [
+       "Prints a dependency tree in the .dot format (the graphviz format, default)",
+       "or the CoNLL/MaltParser format (flag -output=conll for training, malt_input",
+       "for unanalysed input).",
+       "By default, the last argument is the head of every abstract syntax",
+       "function; moreover, the head depends on the head of the function above.",
+       "The graph can be saved in a file by the wf command as usual.",
+       "If the -view flag is defined, the graph is saved in a temporary file",
+       "which is processed by graphviz and displayed by the program indicated",
+       "by the flag. The target format is png, unless overridden by the",
+       "flag -format."
+       ],
+     exec = \env@(pgf, mos) opts es -> do
+         let debug = isOpt "v" opts
+         let file = valStrOpts "file" "" opts
+         let outp = valStrOpts "output" "dot" opts
+         mlab <- case file of
+           "" -> return Nothing
+           _  -> (Just . H.getDepLabels . lines) `fmap` restricted (readFile file)
+         let lang = optLang pgf opts
+         let grphs = unlines $ map (H.graphvizDependencyTree outp debug mlab Nothing pgf lang) es
+         if isFlag "view" opts || isFlag "format" opts then do
+           let file s = "_grphd." ++ s
+           let view = optViewGraph opts
+           let format = optViewFormat opts
+           restricted $ writeUTF8File (file "dot") grphs
+           restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+           restrictedSystem $ view ++ " " ++ file format
+           return void
+          else return $ fromString grphs,
+     examples = [
+       mkEx "gr | vd              -- generate a tree and show dependency tree in .dot",
+       mkEx "gr | vd -view=open   -- generate a tree and display dependency tree on a Mac",
+       mkEx "gr -number=1000 | vd -file=dep.labels -output=malt      -- generate training treebank",
+       mkEx "gr -number=100 | vd -file=dep.labels -output=malt_input -- generate test sentences"
+       ],
+     options = [
+       ("v","show extra information")
+       ],
+     flags = [
+       ("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"),
+       ("format","format of the visualization file (default \"png\")"),
+       ("output","output format of graph source (default \"dot\")"),
+       ("view","program to open the resulting file (default \"open\")"),
+       ("lang","the language of analysis")
+       ]
+    }),
+-}
+
+  ("vp", emptyCommandInfo {
+     longname = "visualize_parse",
+     synopsis = "show parse tree graphically",
+     explanation = unlines [
+       "Prints a parse tree in the .dot format (the graphviz format).",
+       "The graph can be saved in a file by the wf command as usual.",
+       "If the -view flag is defined, the graph is saved in a temporary file",
+       "which is processed by graphviz and displayed by the program indicated",
+       "by the flag. The target format is png, unless overridden by the",
+       "flag -format."
+       ],
+     exec = needPGF $ \opts arg env@(pgf, concs) ->
+      do let es = toExprs arg
+         let concs = optConcs env opts
+
+         let gvOptions=graphvizDefaults{noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
+                                        noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
+                                        noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
+                                        nodeFont = valStrOpts "nodefont" "" opts,
+                                        leafFont = valStrOpts "leaffont" "" opts,
+                                        nodeColor = valStrOpts "nodecolor" "" opts,
+                                        leafColor = valStrOpts "leafcolor" "" opts,
+                                        nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts,
+                                        leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
+                                       }
+
+         let grph= if null es || null concs
+                   then []
+                   else graphvizParseTree (snd (head concs)) gvOptions (cExpr (head es))
+         if isFlag "view" opts || isFlag "format" opts then do
+           let file s = "_grph." ++ s
+           let view = optViewGraph opts
+           let format = optViewFormat opts
+           restricted $ writeUTF8File (file "dot") grph
+           restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+           restrictedSystem $ view ++ " " ++ file format
+           return void
+          else return $ fromString grph,
+     examples = [
+       mkEx "p -lang=Eng \"John walks\" | vp  -- generate a tree and show parse tree as .dot script",
+       mkEx "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac"
+       ],
+     options = [
+       ("showcat","show categories in the tree nodes (default)"),
+       ("nocat","don't show categories"),
+       ("showfun","show function names in the tree nodes"),
+       ("nofun","don't show function names (default)"),
+       ("showleaves","show the leaves of the tree (default)"),
+       ("noleaves","don't show the leaves of the tree (i.e., only the abstract tree)")
+       ],
+     flags = [
+       ("lang","the language to visualize"),
+       ("format","format of the visualization file (default \"png\")"),
+       ("view","program to open the resulting file (default \"open\")"),
+       ("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
+       ("leaffont","font for tree leaves (default: nodefont)"),
+       ("nodecolor","color for tree nodes (default: black -- graphviz standard color)"),
+       ("leafcolor","color for tree leaves (default: nodecolor)"),
+       ("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)"),
+       ("leafedgestyle","edge style for links to leaves (solid/dashed/dotted/bold, default: dashed)")
+       ]
+    }),
+
+  ("vt", emptyCommandInfo {
+     longname = "visualize_tree",
+     synopsis = "show a set of trees graphically",
+     explanation = unlines [
+       "Prints a set of trees in the .dot format (the graphviz format).",
+       "The graph can be saved in a file by the wf command as usual.",
+       "If the -view flag is defined, the graph is saved in a temporary file",
+       "which is processed by graphviz and displayed by the program indicated",
+       "by the flag. The target format is postscript, unless overridden by the",
+       "flag -format."
+       ],
+     exec = needPGF $ \opts arg env@(pgf, _) ->
+       let es = toExprs arg in
+       if isOpt "api" opts
+       then do
+         mapM_ (putStrLn . exprToAPI) es
+         return void
+       else do
+         let gvOptions=graphvizDefaults{noFun = isOpt "nofun" opts,
+                                        noCat = isOpt "nocat" opts,
+                                        nodeFont = valStrOpts "nodefont" "" opts,
+                                        nodeColor = valStrOpts "nodecolor" "" opts,
+                                        nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts
+                                       }
+         let grph = unlines (map (graphvizAbstractTree pgf gvOptions . cExpr) es)
+         if isFlag "view" opts || isFlag "format" opts then do
+           let file s = "_grph." ++ s
+           let view = optViewGraph opts
+           let format = optViewFormat opts
+           restricted $ writeUTF8File (file "dot") grph
+           restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format
+           restrictedSystem $ view  ++ " " ++ file format
+           return void
+          else return $ fromString grph,
+     examples = [
+       mkEx "p \"hello\" | vt              -- parse a string and show trees as graph script",
+       mkEx "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac"
+       ],
+     options = [
+       ("api", "show the tree with function names converted to 'mkC' with value cats C"),
+       ("nofun","don't show functions but only categories"),
+       ("nocat","don't show categories but only functions")
+       ],
+     flags = [
+       ("format","format of the visualization file (default \"png\")"),
+       ("view","program to open the resulting file (default \"open\")"),
+       ("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
+       ("nodecolor","color for tree nodes (default: black -- graphviz standard color)"),
+       ("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)")
+       ]
+     }),
+
+  ("ai", emptyCommandInfo {
+     longname = "abstract_info",
+     syntax = "ai IDENTIFIER  or  ai EXPR",
+     synopsis = "Provides an information about a function, an expression or a category from the abstract syntax",
+     explanation = unlines [
+       "The command has one argument which is either function, expression or",
+       "a category defined in the abstract syntax of the current grammar. ",
+       "If the argument is a function then its type is printed out.",
+       "If it is a category then the category definition is printed.",
+       "If a whole expression is given it prints the expression with refined",
+       "metavariables and the type of the expression."
+       ],
+     exec = needPGF $ \opts args env@(pgf,cncs) ->
+       case map cExpr (toExprs args) of
+         [e] -> case unApp e of
+                  Just (id,[]) -> return (fromString 
+                                            (case functionType pgf id of
+                                               Just ty -> showFun id ty
+                                               Nothing -> let funs = functionsByCat pgf id
+                                                          in showCat id funs))
+                                  where
+                                    showCat c funs = "cat "++c++
+                                                     " ;\n\n"++
+                                                     unlines [showFun f ty| f<-funs,
+                                                                            Just ty <- [functionType pgf f]]
+                                    showFun f ty = "fun "++f++" : "++showType [] ty++" ;"
+                  _  -> case inferExpr pgf e of
+                          Left msg     -> error msg
+                          Right (e,ty) -> do putStrLn ("Expression:  "++PGF2.showExpr [] e)
+                                             putStrLn ("Type:        "++PGF2.showType [] ty)
+                                             putStrLn ("Probability: "++show (treeProbability pgf e))
+                                             return void
+         _           -> do putStrLn "a single function name or category name is expected"
+                           return void,
+     needsTypeCheck = False
+     })
+  ]
+ where
+   cParse env@(pgf,_) opts ss = 
+        parsed [ parse cnc cat s | s<-ss,(lang,cnc)<-cncs]
+     where
+       cat = optType pgf opts
+       cncs = optConcs env opts
+       parsed rs = Piped (Exprs ts,unlines msgs)
+          where
+            ts = [hsExpr t|ParseOk ts<-rs,(t,p)<-takeOptNum opts ts]
+            msgs = concatMap mkMsg rs
+
+            mkMsg (ParseOk ts) = (map (PGF2.showExpr [] . fst).takeOptNum opts) ts
+            mkMsg (ParseFailed _ tok) = ["Parse failed: "++tok]
+            mkMsg (ParseIncomplete)   = ["The sentence is incomplete"]
+
+   optLins env opts ts = case opts of
+     _ | isOpt "groups" opts ->
+       concatMap snd $ groupResults
+         [[(lang, s) | (lang,concr) <- optConcs env opts,s <- linear opts lang concr t] | t <- ts]
+     _ -> concatMap (optLin env opts) ts
+   optLin env@(pgf,_) opts t =
+     case opts of
+       _ | isOpt "treebank" opts ->
+         (abstractName pgf ++ ": " ++ PGF2.showExpr [] t) :
+         [lang ++ ": " ++ s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t]
+       _ -> [s | (lang,concr) <- optConcs env opts, s<-linear opts lang concr t]
+
+   linear :: [Option] -> ConcName -> Concr -> PGF2.Expr -> [String]
+   linear opts lang concr = case opts of
+       _ | isOpt "all"     opts -> concat . map (map snd) . tabularLinearizeAll concr
+       _ | isOpt "list"    opts -> (:[]) . commaList .
+                                   concatMap (map snd) . tabularLinearizeAll concr
+       _ | isOpt "table"   opts -> concatMap (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
+       _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
+       _                        -> (:[]) . linearize concr
+
+   groupResults :: [[(ConcName,String)]] -> [(ConcName,[String])]
+   groupResults = Map.toList . foldr more Map.empty . start . concat
+     where
+       start ls = [(l,[s]) | (l,s) <- ls]
+       more (l,s) = 
+          Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s
+
+   optConcs = optConcsFlag "lang"
+
+   optConcsFlag f (pgf,cncs) opts =
+       case valStrOpts f "" opts of
+         "" -> Map.toList cncs
+         lang -> mapMaybe pickLang (chunks ',' lang)
+     where
+       pickLang l = pick l `mplus` pick fl
+         where
+           fl = abstractName pgf++l
+           pick l = (,) l `fmap` Map.lookup l cncs
+
+{-
+   -- replace each non-atomic constructor with mkC, where C is the val cat
+   tree2mk pgf = H.showExpr [] . t2m where
+     t2m t = case H.unApp t of
+       Just (cid,ts@(_:_)) -> H.mkApp (mk cid) (map t2m ts)
+       _ -> t
+     mk = H.mkCId . ("mk" ++) . H.showCId . H.lookValCat (H.abstract pgf)
+
+   unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
+
+   getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
+     lexs -> case lookup lang
+               [(H.mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
+       Just le -> chunks ',' le
+       _ -> []
+-}
+   commaList [] = []
+   commaList ws = concat $ head ws : map (", " ++) (tail ws)
+
+   optFile opts = valStrOpts "file" "_gftmp" opts
+
+   optType pgf opts =
+     case listFlags "cat" opts of
+       v:_ -> let str = valueString v
+              in case readType str of
+                   Just ty -> case checkType pgf ty of
+                                Left msg -> error msg
+                                Right ty -> ty
+                   Nothing -> error ("Can't parse '"++str++"' as a type")
+       _   -> startCat pgf
+
+   optViewFormat opts = valStrOpts "format" "png" opts
+   optViewGraph opts = valStrOpts "view" "open" opts
+{-
+   optNum opts = valIntOpts "number" 1 opts
+-}
+   optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
+   takeOptNum opts = take (optNumInf opts)
+
+   returnFromCExprs = returnFromExprs . map hsExpr
+   returnFromExprs es =
+      return $ case es of
+                 [] -> pipeMessage "no trees found"
+                 _  -> fromExprs es
+
+   prGrammar env@(pgf,cncs) opts
+     | isOpt "langs" opts = return . fromString . unwords $ (map fst (optConcs env opts))
+     | isOpt "cats" opts = return . fromString . unwords $ categories pgf
+     | isOpt "funs" opts = return . fromString . unwords $ functions pgf
+     | isOpt "missing" opts = return . fromString . unwords $
+                                 [f | f <- functions pgf, not (and [hasLinearization concr f | (_,concr) <- optConcs env opts])]
+     | isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . snd) $ optConcs env opts
+     | isOpt "words"    opts = return $ fromString $ concatMap (prAllWords . snd) $ optConcs env opts
+     | isOpt "lexc"     opts = return $ fromString $ concatMap (prLexcLexicon . snd) $ optConcs env opts
+     | otherwise = return void
+
+   gizaAlignment pgf src_cnc tgt_cnc e =
+     let src_res   = alignWords src_cnc e
+         tgt_res   = alignWords tgt_cnc e
+         alignment = [show i++"-"++show j | (i,(_,src_fids)) <- zip [0..] src_res, (j,(_,tgt_fids)) <- zip [0..] tgt_res, not (null (intersect src_fids tgt_fids))]
+     in (unwords (map fst src_res), unwords (map fst tgt_res), unwords alignment)
+
+   morphos env opts s =
+     [(s,res) | (lang,concr) <- optConcs env opts, let res = lookupMorpho concr s, not (null res)]
+{-
+   mexp xs = case xs of
+     t:_ -> Just t
+     _   -> Nothing
+-}
+   -- ps -f -g s returns g (f s)
+{-
+   treeOps pgf opts s = foldr app s (reverse opts) where
+     app (OOpt  op)         | Just (Left  f) <- treeOp pgf op = f
+     app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (H.mkCId x)
+     app _                                                    = id
+
+treeOpOptions pgf = [(op,expl) | (op,(expl,Left  _)) <- allTreeOps pgf]
+treeOpFlags   pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
+
+translationQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Language -> H.Type -> IO ()
+translationQuiz mex pgf ig og typ = do
+  tts <- translationList mex pgf ig og typ infinity
+  mkQuiz "Welcome to GF Translation Quiz." tts
+
+morphologyQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Type -> IO ()
+morphologyQuiz mex pgf ig typ = do
+  tts <- morphologyList mex pgf ig typ infinity
+  mkQuiz "Welcome to GF Morphology Quiz." tts
+
+-- | the maximal number of precompiled quiz problems
+infinity :: Int
+infinity = 256
+-}
+prLexcLexicon :: Concr -> String
+prLexcLexicon concr =
+  unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w  ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"]
+ where
+  morpho = fullFormLexicon concr
+  prLexc l p = l ++ concat (mkTags (words p))
+  mkTags p = case p of
+    "s":ws -> mkTags ws   --- remove record field
+    ws -> map ('+':) ws
+
+  multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
+  -- thick_A+(AAdj+Posit+Gen):thick's # ;
+
+prFullFormLexicon :: Concr -> String
+prFullFormLexicon concr =
+  unlines (map prMorphoAnalysis (fullFormLexicon concr))
+
+prAllWords :: Concr -> String
+prAllWords concr =
+  unwords [w | (w,_) <- fullFormLexicon concr]
+
+prMorphoAnalysis :: (String,[MorphoAnalysis]) -> String
+prMorphoAnalysis (w,lps) =
+  unlines (w:[fun ++ " : " ++ cat | (fun,cat,p) <- lps])
+
+hsExpr c =
+  case unApp c of
+    Just (f,cs) -> H.mkApp (H.mkCId f) (map hsExpr cs)
+    _ -> case unStr c of
+           Just str -> H.mkStr str
+           _ -> 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
+           _ -> 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
+     case mb_pgf of
+       Just pgf -> liftSIO $ exec opts ts (pgf,cncs)
+       _ -> fail "Import a grammar before using this command"

src/compiler/GF/Command/CommonCommands.hs

@@ -3,6 +3,7 @@
 -- elsewhere
 module GF.Command.CommonCommands where
 import Data.List(sort)
+import Data.Char (isSpace)
 import GF.Command.CommandInfo
 import qualified Data.Map as Map
 import GF.Infra.SIO
@@ -15,7 +16,7 @@ import GF.Text.Pretty
 import GF.Text.Transliterations
 import GF.Text.Lexing(stringOp,opInEnv)
 
-import PGF2(showExpr)
+import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
 
 extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
 
@@ -101,7 +102,9 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
        "To see transliteration tables, use command ut."
        ],
      examples = [
+--       mkEx "l (EAdd 3 4) | ps -code         -- linearize code-like output",
        mkEx "l (EAdd 3 4) | ps -unlexcode    -- linearize code-like output",
+--       mkEx "ps -lexer=code | p -cat=Exp     -- parse code-like input",
        mkEx "ps -lexcode | p -cat=Exp        -- parse code-like input",
        mkEx "gr -cat=QCl | l | ps -bind      -- linearization output from LangFin",
        mkEx "ps -to_devanagari \"A-p\"         -- show Devanagari in UTF8 terminal",
@@ -114,11 +117,13 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
                let (os,fs) = optsAndFlags opts
                trans <- optTranslit opts
 
-               if isOpt "lines" opts 
-                  then return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
-                  else return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
+               case opts of
+                 _ | isOpt "lines" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
+                 _ | isOpt "paragraphs" opts -> return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toParagraphs $ toStrings x
+                 _ -> return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
      options = [
-       ("lines","apply the operation separately to each input line, returning a list of lines")
+       ("lines","apply the operation separately to each input line, returning a list of lines"),
+       ("paragraphs","apply separately to each input paragraph (as separated by empty lines), returning a list of lines")
        ] ++
        stringOpOptions,
      flags = [
@@ -173,6 +178,12 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
        mkEx "gt | l | ? wc  -- generate trees, linearize, and count words"
        ]
      }),
+  ("tt", emptyCommandInfo {
+     longname = "to_trie",
+     syntax = "to_trie",
+     synopsis = "combine a list of trees into a trie",
+     exec = \ _ -> return . fromString . trie . toExprs
+    }),
   ("ut", emptyCommandInfo {
      longname = "unicode_table",
      synopsis = "show a transliteration table for a unicode character set",
@@ -220,6 +231,7 @@ envFlag fs =
     _ -> Nothing
 
 stringOpOptions = sort $ [
+       ("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
        ("chars","lexer that makes every non-space character a token"),
        ("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
        ("from_utf8","decode from utf8 (default)"),
@@ -244,6 +256,27 @@ stringOpOptions = sort $ [
         ("to_"   ++ p, "from GF " ++ n ++ " transliteration to unicode")] |
                                     (p,n) <- transliterationPrintNames]
 
+trie = render . pptss . H.toTrie . map H.toATree
+  where
+    pptss [ts] = "*"<+>nest 2 (ppts ts)
+    pptss tss  = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss]
+
+    ppts = vcat . map ppt
+
+    ppt t =
+      case t of
+        H.Oth e     -> pp (H.showExpr [] e)
+        H.Ap f [[]] -> pp (H.showCId f)
+        H.Ap f tss  -> H.showCId f $$ nest 2 (pptss tss)
+
 -- ** Converting command input
 toString  = unwords . toStrings
 toLines = unlines . toStrings
+
+toParagraphs = map (unwords . words) . toParas
+  where
+    toParas ls = case break (all isSpace) ls of
+      ([],[])   -> []
+      ([],_:ll) -> toParas ll
+      (l, [])   -> [unwords l]
+      (l, _:ll) -> unwords l : toParas ll

src/compiler/GF/Command/Importing.hs

@@ -1,7 +1,7 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
-import PGF2
-import PGF2.Internal(unionPGF)
+import PGF
+import PGF.Internal(optimizePGF,unionPGF,msgUnionPGF)
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)
@@ -17,16 +17,14 @@ import GF.Data.ErrM
 
 import System.FilePath
 import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Control.Monad(foldM)
 
 -- import a grammar in an environment where it extends an existing grammar
-importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
-importGrammar pgf0 _    []    = return pgf0
+importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
+importGrammar pgf0 _ [] = return pgf0
 importGrammar pgf0 opts files =
   case takeExtensions (last files) of
-    ".cf"   -> fmap Just $ importCF opts files getBNFCRules bnfc2cf
-    ".ebnf" -> fmap Just $ importCF opts files getEBNFRules ebnf2cf
+    ".cf"   -> importCF opts files getBNFCRules bnfc2cf
+    ".ebnf" -> importCF opts files getEBNFRules ebnf2cf
     ".gfm"  -> do
       ascss <- mapM readMulti files
       let cs = concatMap snd ascss
@@ -38,15 +36,14 @@ importGrammar pgf0 opts files =
         Bad msg -> do putStrLn ('\n':'\n':msg)
                       return pgf0
     ".pgf" -> do
-      mapM readPGF files >>= foldM ioUnionPGF pgf0
+      pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
+      ioUnionPGF pgf0 pgf2
     ext -> die $ "Unknown filename extension: " ++ show ext
 
-ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)
-ioUnionPGF Nothing    two = return (Just two)
-ioUnionPGF (Just one) two =
-  case unionPGF one two of
-    Nothing         -> putStrLn "Abstract changed, previous concretes discarded." >> return (Just two)
-    Just pgf        -> return (Just pgf)
+ioUnionPGF :: PGF -> PGF -> IO PGF
+ioUnionPGF one two = case msgUnionPGF one two of
+  (pgf, Just msg) -> putStrLn msg >> return pgf
+  (pgf,_)         -> return pgf
 
 importSource :: Options -> [FilePath] -> IO SourceGrammar
 importSource opts files = fmap (snd.snd) (batchCompile opts files)
@@ -59,6 +56,7 @@ importCF opts files get convert = impCF
       startCat <- case rules of
                     (Rule cat _ _ : _) -> return cat
                     _                  -> fail "empty CFG"
-      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
-      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
-      return pgf
+      let pgf = cf2pgf (last files) (mkCFG startCat Set.empty rules)
+      probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf
+      return $ setProbabilities probs 
+             $ if flag optOptimizePGF opts then optimizePGF pgf else pgf

src/compiler/GF/Command/Interpreter.hs

@@ -6,11 +6,13 @@ module GF.Command.Interpreter (
 import GF.Command.CommandInfo
 import GF.Command.Abstract
 import GF.Command.Parse
+import PGF.Internal(Expr(..))
 import GF.Infra.UseIO(putStrLnE)
-import PGF2
 
 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 ()
@@ -53,8 +56,17 @@ interpretPipe env cs = do
 -- | macro definition applications: replace ?i by (exps !! i)
 appCommand :: CommandArguments -> Command -> Command
 appCommand args c@(Command i os arg) = case arg of
-  AExpr e -> Command i os (AExpr (exprSubstitute e (toExprs args)))
+  AExpr e -> Command i os (AExpr (app e))
   _       -> c
+ where
+  xs = toExprs args
+
+  app e = case e of
+    EAbs b x e -> EAbs b x (app e)
+    EApp e1 e2 -> EApp (app e1) (app e2)
+    ELit l     -> ELit l
+    EMeta i    -> xs !! i
+    EFun x     -> EFun x
 
 -- | return the trees to be sent in pipe, and the output possibly printed
 --interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
@@ -101,4 +113,4 @@ getCommandTrees env needsTypeCheck a args =
     ATerm t -> return (Term t)
     ANoArg  -> return args  -- use piped
   where
-    one e = return (Exprs [(e,0)]) -- ignore piped
+    one e = return (Exprs [e]) -- ignore piped

src/compiler/GF/Command/Parse.hs

@@ -1,6 +1,6 @@
 module GF.Command.Parse(readCommandLine, pCommand) where
 
-import PGF2(pExpr,pIdent)
+import PGF(pExpr,pIdent)
 import GF.Grammar.Parser(runPartial,pTerm)
 import GF.Command.Abstract
 
@@ -22,7 +22,7 @@ pCommandLine =
 pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
 
 pCommand = (do
-  cmd  <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P pIdent))
+  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
   skipSpaces
   opts <- sepBy pOption skipSpaces
   arg  <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
@@ -37,7 +37,7 @@ pCommand = (do
 
 pOption = do
   char '-'
-  flg <- readS_to_P pIdent
+  flg <- pIdent
   option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
 
 pValue = do
@@ -52,9 +52,9 @@ pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
 
 pArgument =
   option ANoArg
-    (fmap AExpr (readS_to_P pExpr)
+    (fmap AExpr pExpr
               <++
-    (skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent)))
+    (skipSpaces >> char '%' >> fmap AMacro pIdent))
 
 pArgTerm = ATerm `fmap` readS_to_P sTerm
   where

src/compiler/GF/Command/TreeOperations.hs

@@ -4,15 +4,15 @@ module GF.Command.TreeOperations (
   treeChunks
   ) where
 
-import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
+import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
 import Data.List
 
 type TreeOp = [Expr] -> [Expr]
 
-treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
+treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp))
 treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
 
-allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
+allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))]
 allTreeOps pgf = [
    ("compute",("compute by using semantic definitions (def)",
       Left  $ map (compute pgf))),

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(grammar2PGF)
+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,(<=<))
+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
@@ -22,23 +23,37 @@ import Data.List(nub)
 import Data.Time(UTCTime)
 import GF.Text.Pretty(render,($$),(<+>),nest)
 
-import PGF2(PGF,readProbabilitiesFromFile)
+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
 link opts (cnc,gr) =
   putPointE Normal opts "linking ... " $ do
     let abs = srcAbsName gr cnc
-    probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
-    pgf <- grammar2PGF opts gr abs probs
+    pgf <- mkCanon2pgf opts gr abs
+    probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
     when (verbAtLeast opts Normal) $ putStrE "OK"
-    return pgf
+    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
@@ -76,10 +91,14 @@ compileModule opts1 env@(_,rfs) file =
   do file <- getRealFile file
      opts0 <- getOptionsFromFile file
      let curr_dir = dropFileName file
-     lib_dir  <- getLibraryDirectory (addOptions opts0 opts1)
-     let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
+     lib_dirs <- getLibraryDirectory (addOptions opts0 opts1)
+     let opts = addOptions (fixRelativeLibPaths curr_dir lib_dirs opts0) opts1
+--     putIfVerb opts $ "curr_dir:" +++ show curr_dir ----
+--     putIfVerb opts $ "lib_dir:" +++ show lib_dirs ----
      ps0 <- extendPathEnv opts
      let ps = nub (curr_dir : ps0)
+--     putIfVerb opts $ "options from file: " ++ show opts0
+--     putIfVerb opts $ "augmented options: " ++ show opts
      putIfVerb opts $ "module search path:" +++ show ps ----
      files <- getAllFiles opts ps rfs file
      putIfVerb opts $ "files to read:" +++ show files ----
@@ -92,13 +111,17 @@ compileModule opts1 env@(_,rfs) file =
       if exists
         then return file
         else if isRelative file
-               then do lib_dir <- getLibraryDirectory opts1
-                       let file1 = lib_dir </> file
-                       exists <- doesFileExist file1
-                       if exists
-                         then return file1
-                         else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
-               else raise (render ("File" <+> file <+> "does not exist."))
+               then do
+                       lib_dirs <- getLibraryDirectory opts1
+                       let candidates = [ lib_dir </> file | lib_dir <- lib_dirs ]
+                       putIfVerb opts1 (render ("looking for: " $$ nest 2 candidates))
+                       file1s <- filterM doesFileExist candidates
+                       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"))
 
 compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
 compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -1,110 +1,99 @@
-{-# LANGUAGE FlexibleContexts, ImplicitParams #-}
+{-# LANGUAGE FlexibleContexts #-}
 module GF.Compile.CFGtoPGF (cf2pgf) where
 
 import GF.Grammar.CFG
 import GF.Infra.UseIO
-import GF.Infra.Option
-import GF.Compile.OptimizePGF
 
-import PGF2
-import PGF2.Internal
+import PGF
+import PGF.Internal
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import Data.Array.IArray
 import Data.List
-import Data.Maybe(fromMaybe)
 
 --------------------------
 -- the compiler ----------
 --------------------------
 
-cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
-cf2pgf opts fpath cf probs = 
- build (let abstr = cf2abstr cf probs
-        in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
+cf2pgf :: FilePath -> ParamCFG -> PGF
+cf2pgf fpath cf = 
+ let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
+ in updateProductionIndices pgf
  where
    name = justModuleName fpath
-   aname = name ++ "Abs"
-   cname = name
+   aname = mkCId (name ++ "Abs")
+   cname = mkCId name
 
-cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
-cf2abstr cfg probs = newAbstr aflags acats afuns
+cf2abstr :: ParamCFG -> Abstr
+cf2abstr cfg = Abstr aflags afuns acats
   where
-    aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
+    aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
 
-    acats  = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
-    afuns  = [(f', dTyp [hypo Explicit "_" (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, [], toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
-                            | rule <- allRules cfg
-                            , let f' = mkRuleName rule]
+    acats  = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
+                            | (cat,rules) <- (Map.toList . Map.fromListWith (++))
+                                                [(cat2id cat, catRules cfg cat) | 
+                                                     cat <- allCats' cfg]]
+    afuns  = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
+                            | rule <- allRules cfg]
 
-    funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
-                     [(cat,[(f',Map.lookup f' probs)]) | rule <- allRules cfg,
-                                                         let cat = cat2id (ruleLhs rule),
-                                                         let f' = mkRuleName rule]
-      where
-        pad :: [(a,Maybe Double)] -> [(a,Double)]
-        pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
-          where
-            deflt = case length [f | (f,Nothing) <- pfs] of
-                      0 -> 0
-                      n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
+    cat2id = mkCId . fst
 
-    toLogProb = realToFrac . negate . log
-
-    cat2id = fst
-
-cf2concr :: (?builder :: Builder s) => Options -> B s AbstrInfo -> ParamCFG -> B s ConcrInfo
-cf2concr opts abstr cfg = 
-  let (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
-           (if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id)
-                (lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
-  in newConcr abstr [] []
-              lindefs' linrefs'
-              productions' cncfuns'
-              sequences' cnccats' totalCats
+cf2concr :: ParamCFG -> Concr
+cf2concr cfg = Concr Map.empty Map.empty
+                     cncfuns lindefsrefs lindefsrefs
+                     sequences productions
+                     IntMap.empty Map.empty
+                     cnccats
+                     IntMap.empty
+                     totalCats
   where
     cats  = allCats' cfg
     rules = allRules cfg
 
-    idSeq = [SymCat 0 0]
-
-    sequences0 = Set.fromList (idSeq : 
+    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : 
                                map mkSequence rules)
-    sequences  = Set.toList sequences0
+    sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
 
-    idFun = ("_",[Set.findIndex idSeq sequences0])
+    idFun = CncFun wildCId (listArray (0,0) [seqid])
+      where
+        seq   = listArray (0,0) [SymCat 0 0]
+        seqid = binSearch seq sequences (bounds sequences)
     ((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
     productions = foldl addProd IntMap.empty (concat (productions0++coercions))
-    cncfuns = reverse cncfuns0
+    cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
 
-    lbls = ["s"]
-    (fid,cnccats) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
-                         [(c,p) | (c,ps) <- cats, p <- ps]
+    lbls = listArray (0,0) ["s"]
+    (fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
+                              [(c,p) | (c,ps) <- cats, p <- ps]
     ((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
+    cnccats = Map.fromList cnccats0
 
-    lindefsrefs = map mkLinDefRef cats
+    lindefsrefs =
+       IntMap.fromList (map mkLinDefRef cats)
 
     convertRule cs (funid,funs) rule =
       let args   = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
           prod   = PApply funid args
-          seqid  = Set.findIndex (mkSequence rule) sequences0
-          fun    = (mkRuleName rule, [seqid])
+          seqid  = binSearch (mkSequence rule) sequences (bounds sequences)
+          fun    = CncFun (mkRuleName rule) (listArray (0,0) [seqid])
           funid' = funid+1
       in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
 
-    mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
+    mkSequence rule = listArray (0,length syms-1) syms
       where
+        syms   = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
+
         convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
         convertSymbol d (Terminal t)        = (d,  SymKS t)
 
     mkCncCat fid (cat,n)
-      | cat == "Int"    = (fid, (cat, fidInt,    fidInt,    lbls))
-      | cat == "Float"  = (fid, (cat, fidFloat,  fidFloat,  lbls))
-      | cat == "String" = (fid, (cat, fidString, fidString, lbls))
+      | cat == "Int"    = (fid, (mkCId cat, CncCat fidInt    fidInt    lbls))
+      | cat == "Float"  = (fid, (mkCId cat, CncCat fidFloat  fidFloat  lbls))
+      | cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
       | otherwise       = let fid' = fid+n+1
-                          in fid' `seq` (fid', (cat, fid, fid+n, lbls))
+                          in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
 
     mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
     mkCoercions (fid,cs) c@(cat,ps ) =
@@ -113,16 +102,25 @@ cf2concr opts abstr cfg =
 
     mkLinDefRef (cat,_) =
       (cat2fid cat 0,[0])
-
+      
     addProd prods (fid,prod) =
       case IntMap.lookup fid prods of
-        Just set -> IntMap.insert fid (prod:set) prods
-        Nothing  -> IntMap.insert fid [prod]     prods
+        Just set -> IntMap.insert fid (Set.insert prod set) prods
+        Nothing  -> IntMap.insert fid (Set.singleton prod)  prods
+
+    binSearch v arr (i,j)
+      | i <= j    = case compare v (arr ! k) of
+                      LT -> binSearch v arr (i,k-1)
+                      EQ -> k
+                      GT -> binSearch v arr (k+1,j)
+      | otherwise = error "binSearch"
+      where
+        k = (i+j) `div` 2
 
     cat2fid cat p =
-      case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
-        (start:_) -> fid+p
-        _         -> error "cat2fid"
+      case Map.lookup (mkCId cat) cnccats of
+        Just (CncCat fid _ _) -> fid+p
+        _                     -> error "cat2fid"
 
     cat2arg c@(cat,[p]) = cat2fid cat p
     cat2arg c@(cat,ps ) =
@@ -133,5 +131,4 @@ cf2concr opts abstr cfg =
 mkRuleName rule =
   case ruleName rule of
 	CFObj n _ -> n
-	_         -> "_"
-
+	_         -> wildCId

src/compiler/GF/Compile/CheckGrammar.hs

@@ -21,6 +21,7 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.CheckGrammar(checkModule) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Infra.Ident
 import GF.Infra.Option
@@ -259,30 +260,18 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
       return (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do
-      (vs,pcs) <- chIn loc "parameter type" $
-                    mkParams 0 [] pcs
-      return (ResParam (Just (L loc pcs)) (Just vs))
-
-    ResValue (L loc ty) _ -> 
-      chIn loc "operation" $ do
-        let (_,Cn x) = typeFormCnc ty
-            is = case Map.lookup x (jments mo) of
-                   Just (ResParam (Just (L _ pcs)) _) -> [i | (f,_,i) <- pcs, f == c]
-                   _                                  -> []
-        case is of
-          [i] -> return (ResValue (L loc ty) i)
-          _   -> checkError (pp "Failed to find the value index for parameter" <+> pp c)
+      ts <- chIn loc "parameter type" $ 
+              liftM concat $ mapM mkPar pcs
+      return (ResParam (Just (L loc pcs)) (Just ts))
 
     _ ->  return info
  where
    gr = prependModule sgr (m,mo)
    chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
 
-   mkParams i vs []             = return (vs,[])
-   mkParams i vs ((f,co,_):pcs) = do
-     vs0 <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
-     (vs,pcs) <- mkParams (i + length vs0) (vs ++ map (mkApp (QC (m,f))) vs0) pcs
-     return (vs,(f,co,i):pcs)
+   mkPar (f,co) = do
+       vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+       return $ map (mkApp (QC (m,f))) vs
 
    checkUniq xss = case xss of
      x:y:xs 

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

@@ -5,6 +5,7 @@ module GF.Compile.Compute.ConcreteNew
             normalForm,
             Value(..), Bind(..), Env, value2term, eval, vapply
            ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Grammar hiding (Env, VGen, VApp, VRecType)
 import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
@@ -14,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
@@ -290,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 $
-                                         ppL loc (hang "unsupported token gluing:" 4
-                                                        (Glue (vt v1) (vt v2)))
+                                originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
+                                                               (Glue (vt v1) (vt v2)))
+                                term = render $ pp  $ Glue (vt v1) (vt v2)
+                            in error $ unlines
+                                [originalMsg
+                                ,""
+                                ,"There was a problem in the expression `"++term++"`, either:"
+                                ,"1) You are trying to use + on runtime arguments, possibly via an oper."
+                                ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive."
+                                ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md"
+                                ]
 
 
 -- | to get a string from a value that represents a sequence of terminals
@@ -317,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
@@ -545,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/Compute/Value.hs

@@ -1,6 +1,6 @@
 module GF.Compile.Compute.Value where
 import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent)
-import PGF2(BindType)
+import PGF.Internal(BindType)
 import GF.Infra.Ident(Ident)
 import Text.Show.Functions()
 import Data.Ix(Ix)

src/compiler/GF/Compile/ExampleBased.hs

@@ -3,7 +3,11 @@ module GF.Compile.ExampleBased (
   configureExBased
   ) where
 
-import PGF2
+import PGF
+--import PGF.Probabilistic
+--import PGF.Morphology
+--import GF.Compile.ToAPI
+
 import Data.List
 
 parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
@@ -33,38 +37,47 @@ convertFile conf src file = do
       (ex,   end) = break (=='"') (tail exend)
     in ((unwords (words cat),ex), tail end)  -- quotes ignored
   pgf = resource_pgf conf
+  morpho = resource_morpho conf
   lang = language conf 
   convEx (cat,ex) = do
     appn "("
     let typ = maybe (error "no valid cat") id $ readType cat
-    ws <- case parse lang typ ex of
-      ParseFailed _ _ -> do
+    ws <- case fst (parse_ pgf lang typ (Just 4) ex) of
+      ParseFailed _ -> do
+        let ws = morphoMissing morpho (words ex)
         appv ("WARNING: cannot parse example " ++ ex) 
+        case ws of
+          [] -> return ()
+          _  -> appv ("  missing words: " ++ unwords ws)
+        return ws
+      TypeError _ ->
         return []
       ParseIncomplete ->
         return []
       ParseOk ts ->
-        case ts of
+        case rank ts of
           (t:tt) -> do
             if null tt 
               then return ()
               else appv ("WARNING: ambiguous example " ++ ex) 
-            appn (printExp conf (fst t))
-            mapM_ (appn . ("  --- " ++) . printExp conf . fst) tt
+            appn t 
+            mapM_ (appn . ("  --- " ++)) tt
             appn ")" 
             return [] 
     return ws
+  rank ts = [printExp conf t ++ "  -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts]
   appf = appendFile file
   appn s = appf s >> appf "\n"
   appv s = appn ("--- " ++ s) >> putStrLn s
 
 data ExConfiguration = ExConf {
-  resource_pgf :: PGF,
+  resource_pgf    :: PGF,
+  resource_morpho :: Morpho,
   verbose  :: Bool,
-  language :: Concr,
-  printExp :: Expr -> String
+  language :: Language,
+  printExp :: Tree -> String
   }
 
-configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
-configureExBased pgf concr pr = ExConf pgf False concr pr
+configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration
+configureExBased pgf morpho lang pr = ExConf pgf morpho False lang pr
 

src/compiler/GF/Compile/Export.hs

@@ -1,10 +1,14 @@
 module GF.Compile.Export where
 
-import PGF2
+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
 import GF.Speech.PGFToCFG
@@ -18,7 +22,6 @@ import GF.Speech.SLF
 import GF.Speech.PrRegExp
 
 import Data.Maybe
-import qualified Data.Map as Map
 import System.FilePath
 import GF.Text.Pretty
 
@@ -32,12 +35,15 @@ exportPGF :: Options
           -> [(FilePath,String)] -- ^ List of recommended file names and contents.
 exportPGF opts fmt pgf = 
     case fmt of
-      FmtPGFPretty    -> multi "txt" (showPGF)
+      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)
+      FmtProlog       -> multi "pl"  grammar2prolog
       FmtBNF          -> single "bnf"   bnfPrinter
       FmtEBNF         -> single "ebnf"  (ebnfPrinter opts)
       FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter opts)
@@ -51,13 +57,20 @@ exportPGF opts fmt pgf =
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
  where
-   name = fromMaybe (abstractName pgf) (flag optName opts)
+   name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
 
    multi :: String -> (PGF -> String) -> [(FilePath,String)]
    multi ext pr = [(name <.> ext, pr pgf)]
 
 -- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
 
-   single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
-   single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages 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
+outputConcr pgf = case languages pgf of
+                    []     -> error "No concrete syntax."
+                    cnc:_  -> cnc

src/compiler/GF/Compile/GenerateBC.hs

@@ -1,10 +1,10 @@
-{-# LANGUAGE CPP #-}
 module GF.Compile.GenerateBC(generateByteCode) where
 
 import GF.Grammar
 import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
 import GF.Data.Operations
-import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
+import PGF(CId,utf8CId)
+import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
 import qualified Data.Map as Map
 import Data.List(nub,mapAccumL)
 import Data.Maybe(fromMaybe)
@@ -63,7 +63,7 @@ compileEquations gr arity st (i:is) eqs       fl bs = whilePP eqs Map.empty
 
     case_instr t =
       case t of
-        (Q (_,id)) -> CASE (showIdent id)
+        (Q (_,id)) -> CASE (i2i id)
         (EInt n)   -> CASE_LIT (LInt n)
         (K s)      -> CASE_LIT (LStr s)
         (EFloat d) -> CASE_LIT (LFlt d)
@@ -105,7 +105,7 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
 compileFun gr eval st vs (Q (m,id))  h0 bs args =
   case lookupAbsDef gr m id of
     Ok (_,Just _)
-       -> (h0,bs,eval st (GLOBAL (showIdent id)) args)
+       -> (h0,bs,eval st (GLOBAL (i2i id)) args)
     _  -> let Ok ty = lookupFunType gr m id
               (ctxt,_,_) = typeForm ty
               c_arity    = length ctxt
@@ -114,14 +114,14 @@ compileFun gr eval st vs (Q (m,id))  h0 bs args =
               diff   = c_arity-n_args
           in if diff <= 0
                then if n_args == 0
-                      then (h0,bs,eval st (GLOBAL (showIdent id)) [])
+                      then (h0,bs,eval st (GLOBAL (i2i id)) [])
                       else let h1  = h0 + 2 + n_args
-                           in (h1,bs,PUT_CONSTR (showIdent id):is1++eval st (HEAP h0) [])
+                           in (h1,bs,PUT_CONSTR (i2i id):is1++eval st (HEAP h0) [])
                else let h1  = h0 + 1 + n_args
                         is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
                         b   = CHECK_ARGS diff :
                               ALLOC (c_arity+2) : 
-                              PUT_CONSTR (showIdent id) : 
+                              PUT_CONSTR (i2i id) : 
                               is2 ++
                               TUCK (ARG_VAR 0) diff :
                               EVAL (HEAP h0) (TailCall diff) :
@@ -167,16 +167,16 @@ compileFun gr eval st vs e _ _ _ = error (show e)
 
 compileArg gr st vs (Q(m,id)) h0 bs =
   case lookupAbsDef gr m id of
-    Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
+    Ok (_,Just _) -> (h0,bs,GLOBAL (i2i id),[])
     _             -> let Ok ty = lookupFunType gr m id
                          (ctxt,_,_) = typeForm ty
                          c_arity    = length ctxt
                      in if c_arity == 0
-                          then (h0,bs,GLOBAL (showIdent id),[])
+                          then (h0,bs,GLOBAL (i2i id),[])
                           else let is2 = [SET (ARG_VAR (i+1)) | i <- [0..c_arity-1]]
                                    b   = CHECK_ARGS c_arity :
                                          ALLOC (c_arity+2) :
-                                         PUT_CONSTR (showIdent id) :
+                                         PUT_CONSTR (i2i id) :
                                          is2 ++
                                          TUCK (ARG_VAR 0) c_arity :
                                          EVAL (HEAP h0) (TailCall c_arity) :
@@ -224,12 +224,12 @@ compileArg gr st vs e           h0 bs =
                 diff   = c_arity-n_args
             in if diff <= 0
                  then let h2  = h1 + 2 + n_args
-                      in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (showIdent id) : is2))
+                      in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (i2i id) : is2))
                  else let h2  = h1 + 1 + n_args
                           is2 = [SET (FREE_VAR i) | i <- [0..n_args-1]] ++ [SET (ARG_VAR (i+1)) | i <- [0..diff-1]]
                           b   = CHECK_ARGS diff :
                                 ALLOC (c_arity+2) :
-                                PUT_CONSTR (showIdent id) :
+                                PUT_CONSTR (i2i id) :
                                 is2 ++
                                 TUCK (ARG_VAR 0) diff :
                                 EVAL (HEAP h0) (TailCall diff) :
@@ -298,6 +298,9 @@ freeVars xs (Vr x)
   | not (elem x xs)     = [x]
 freeVars xs e           = collectOp (freeVars xs) e
 
+i2i :: Ident -> CId
+i2i = utf8CId . ident2utf8
+
 push_is :: Int -> Int -> [IVal] -> [IVal]
 push_is i 0 is = is
 push_is i n is = ARG_VAR i : push_is (i-1) (n-1) is

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -13,9 +13,8 @@ module GF.Compile.GeneratePMCFG
     (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
     ) where
 
-import qualified PGF2 as PGF2
-import qualified PGF2.Internal as PGF2
-import PGF2.Internal(Symbol(..),fidVar)
+--import PGF.CId
+import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)
 
 import GF.Infra.Option
 import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -42,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
@@ -69,7 +69,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
 
 
 --addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
-addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
 --when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
   let pres  = protoFCat gr res val
       pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
@@ -93,7 +93,7 @@ addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin
     ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
   seqs1 `seq` stats `seq` return ()
   when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
-  return (seqs1,CncFun mty mlin mprn (Just pmcfg))
+  return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
   where
     (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
 
@@ -103,11 +103,11 @@ addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin
           newArgs  = map getFIds newArgs'
       in addFunction env0 newCat fun newArgs
 
-addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat)) 
-                                                  mdef@(Just (L loc1 def))
-                                                  mref@(Just (L loc2 ref))
-                                                  mprn
-                                                  Nothing) = do
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) 
+                                                             mdef@(Just (L loc1 def))
+                                                             mref@(Just (L loc2 ref))
+                                                             mprn
+                                                             Nothing) = do
   let pcat = protoFCat gr (am,id) lincat
       pvar = protoFCat gr (MN identW,cVar) typeStr
 
@@ -132,7 +132,7 @@ addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat))
   let pmcfg     = getPMCFG pmcfgEnv2
 
   when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
-  seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
+  seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
   where
     addLindef lins (newCat', newArgs') env0 =
       let [newCat] = getFIds newCat'
@@ -158,15 +158,12 @@ convert opts gr cenv loc term ty@(_,val) pargs =
             args = map Vr vars
             vars = map (\(bt,x,t) -> x) context
 
-pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
-pgfCncCat gr id lincat index =
+pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
+pgfCncCat gr lincat index =
   let ((_,size),schema) = computeCatRange gr lincat
-  in ( id
-     , index
-     , index+size-1
-     , map (renderStyle style{mode=OneLineMode} . ppPath)
-           (getStrPaths schema)
-     )
+  in PGF.CncCat index (index+size-1)
+                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) 
+                                    (getStrPaths schema)))
   where
     getStrPaths :: Schema Identity s c -> [Path]
     getStrPaths = collect CNil []
@@ -200,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
@@ -475,7 +475,7 @@ goV (CPar t)     rpath ss = restrictHead (reversePath rpath) t >> return ss
 ----------------------------------------------------------------------
 -- SeqSet
 
-type SeqSet   = Map.Map [Symbol] SeqId
+type SeqSet   = Map.Map Sequence SeqId
 
 addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
 addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
@@ -504,11 +504,13 @@ mapAccumL' f s (x:xs) = (s'',y:ys)
                               !(s'',ys) = mapAccumL' f s' xs
 
 addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
-addSequence seqs seq =
+addSequence seqs lst =
   case Map.lookup seq seqs of
     Just id -> (seqs,id)
     Nothing -> let !last_seq = Map.size seqs
                in (Map.insert seq last_seq seqs, last_seq)
+  where
+    seq = mkArray lst
 
 
 ------------------------------------------------------------
@@ -616,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/GetGrammar.hs

@@ -50,13 +50,20 @@ getSourceModule opts file0 =
        Right (i,mi0) ->
          do liftIO $ removeTemp tmp
             let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
-            case renameEncoding `fmap` flag optEncoding (mflags mi0) of
-              Just coding' -> 
-                when (coding/=coding') $
+                optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
+            case (optCoding,optCoding') of
+              {-
+              (Nothing,Nothing) ->
+                  unless (BS.all isAscii raw) $
+                    ePutStrLn $ file0++":\n    Warning: default encoding has changed from Latin-1 to UTF-8"
+              -}
+              (_,Just coding') -> 
+                  when (coding/=coding') $
                   raise $ "Encoding mismatch: "++coding++" /= "++coding'
                 where coding = maybe defaultEncoding renameEncoding optCoding
               _ -> return ()
-            return (i,mi)
+          --liftIO $ transcodeModule' (i,mi) -- old lexer
+            return (i,mi) -- new lexer
 
 getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
 getBNFCRules opts fpath = do

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -17,14 +17,15 @@ import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
-import GF.Infra.Option(optionsPGF)
-import PGF2.Internal(Literal(..))
+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))
@@ -72,7 +73,7 @@ concrete2canonical gr cenv absname cnc modinfo =
       [lincat|(_,Left lincat)<-defs]
       [lin|(_,Right lin)<-defs]
   where
-    defs = concatMap (toCanonical gr absname cenv) . 
+    defs = concatMap (toCanonical gr absname cenv) .
            M.toList $
            jments modinfo
 
@@ -189,7 +190,7 @@ convert' gr vs = ppT
         _ -> VarValue (gQId cPredef n) -- hmm
       where
        p = PredefValue . PredefId
-      
+
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
@@ -353,9 +354,9 @@ paramType gr q@(_,n) =
             [ParamAliasDef ((gQId m n)) (convType t)])
       _ -> ((S.empty,S.empty),[])
   where
-    param m (n,ctx,_) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
+    param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
     argTypes = S.unions . map argTypes1
-    argTypes1 (n,ctx,_) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
+    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
 
 lblId = LabelId . render -- hmm
 modId (MN m) = ModId (showIdent m)

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -0,0 +1,468 @@
+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, forM, forM_)
+import qualified Control.Monad.State.Strict as CMS
+import Data.List (elemIndex)
+import qualified Data.List as L
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromJust, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Environment (lookupEnv)
+import System.FilePath ((</>), (<.>))
+import Text.Printf (printf)
+
+import qualified Debug.Trace
+trace x = Debug.Trace.trace ("> " ++ show x) (return ())
+
+mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
+mkCanon2lpgf opts gr am = do
+  debug <- isJust <$> lookupEnv "DEBUG"
+  when debug $ do
+    ppCanonical debugDir canon
+    dumpCanonical debugDir canon
+  (an,abs) <- mkAbstract ab
+  cncs     <- mapM (mkConcrete debug ab) cncs
+  let lpgf = LPGF {
+    L.absname = an,
+    L.abstract = abs,
+    L.concretes = Map.fromList cncs
+  }
+  when debug $ ppLPGF debugDir lpgf
+  return lpgf
+  where
+    canon@(C.Grammar ab cncs) = grammar2canonical opts am gr
+
+mkAbstract :: (ErrorMonad err) => C.Abstract -> err (CId, L.Abstract)
+mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {})
+
+mkConcrete :: (ErrorMonad err) => Bool -> C.Abstract -> C.Concrete -> err (CId, L.Concrete)
+mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params0 lincats lindefs0) = do
+  let
+    -- Some transformations on canonical grammar
+
+    params :: [C.ParamDef]
+    params = inlineParamAliases params0
+
+    lindefs :: [C.LinDef]
+    lindefs =
+      [ C.LinDef funId varIds linValue'
+      | (C.LinDef funId varIds linValue) <- lindefs0
+      , let Right linType = lookupLinType funId
+      , let linValue' = cleanupRecordFields linValue linType
+      ]
+
+    -- 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
+
+    -- 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
+
+    -- Code generation
+
+    -- | Main code generation function
+    mkLin :: C.LinDef -> CodeGen (CId, L.LinFun)
+    mkLin (C.LinDef funId varIds linValue) = do
+      -- when debug $ trace funId
+      (lf, _) <- val2lin' linValue --skip memoisation at top level
+      return (fi2i funId, lf)
+      where
+        val2lin :: C.LinValue -> CodeGen (L.LinFun, Maybe C.LinType)
+        val2lin lv@(C.TableValue _ _) = do
+        -- val2lin lv@(C.ParamConstant _) = do
+          m <- CMS.get
+          case Map.lookup lv m of
+            Just r -> return r
+            Nothing -> do
+              r <- val2lin' lv
+              CMS.modify (Map.insert lv r)
+              return r
+        val2lin lv = val2lin' lv
+
+        val2lin' :: C.LinValue -> CodeGen (L.LinFun, Maybe C.LinType)
+        val2lin' lv = case lv of
+
+          C.ConcatValue v1 v2 -> do
+            (v1',t1) <- val2lin v1
+            (v2',t2) <- val2lin v2
+            return (L.Concat v1' v2', t1 <|> t2) -- t1 else t2
+
+          C.LiteralValue ll -> case ll of
+            C.FloatConstant f -> return (L.Token $ T.pack $ show f, Just C.FloatType)
+            C.IntConstant i -> return (L.Token $ T.pack $ show i, Just C.IntType)
+            C.StrConstant s -> return (L.Token $ T.pack s, Just C.StrType)
+
+          C.ErrorValue err -> return (L.Error err, Nothing)
+
+          C.ParamConstant (C.Param pid lvs) -> do
+            let
+              collectProjections :: C.LinValue -> CodeGen [L.LinFun]
+              collectProjections (C.ParamConstant (C.Param pid lvs)) = do
+                def <- CMS.lift $ lookupParamDef pid
+                let (C.ParamDef tpid defpids) = def
+                pidIx <- CMS.lift $ 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 <- CMS.lift $ 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)
+            _ -> CMS.lift $ 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] -> CodeGen (L.LinFun, Maybe C.LinType)
+              handleGroup [C.TableRow patt lv] =
+                case reducePattern patt of
+                  Just patt' -> do
+                    (lf,lt) <- handleGroup [C.TableRow patt' lv]
+                    return (L.Tuple [lf],lt)
+                  Nothing    -> val2lin lv
+              handleGroup rows = do
+                let rows' = map reduceRow rows
+                val2lin (C.TableValue lt rows') -- lt is wrong here, but is unused
+
+              reducePattern :: C.LinPattern -> Maybe C.LinPattern
+              reducePattern patt =
+                case patt of
+                  C.ParamPattern (C.Param _ []) -> Nothing
+                  C.ParamPattern (C.Param _ patts) -> Just $ C.ParamPattern (C.Param pid' patts')
+                    where
+                      C.ParamPattern (C.Param pid1 patts1) = head patts
+                      pid' = pid1
+                      patts' = patts1 ++ tail patts
+
+                  C.RecordPattern [] -> Nothing
+                  C.RecordPattern (C.RecordRow lid patt:rrs) ->
+                    case reducePattern patt of
+                      Just patt' -> Just $ C.RecordPattern (C.RecordRow lid patt':rrs)
+                      Nothing    -> if null rrs then Nothing else Just $ C.RecordPattern rrs
+
+                  _ -> error $ printf "Unhandled pattern in reducing: %s" (show patt)
+
+              reduceRow :: C.TableRowValue -> C.TableRowValue
+              reduceRow (C.TableRow patt lv) =
+                let Just patt' = reducePattern patt
+                in  C.TableRow patt' lv
+
+            -- ts :: [(L.LinFun, Maybe C.LinType)]
+            ts <- mapM handleGroup grps
+
+            -- return
+            let typ = case ts of
+                  (_, Just tst):_ -> Just $ C.TableType lt tst
+                  _ -> Nothing
+            return (L.Tuple (map fst ts), typ)
+
+          -- TODO TuplePattern, WildPattern?
+
+          C.TupleValue lvs -> do
+            ts <- mapM val2lin lvs
+            return (L.Tuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts))
+
+          C.VariantValue [] -> return (L.Empty, Nothing) -- TODO Just C.StrType ?
+          C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first
+
+          C.VarValue (C.VarValueId (C.Unqual v)) -> do
+            ix <- CMS.lift $ eitherElemIndex (C.VarId v) varIds
+            lt <- CMS.lift $ lookupLinTypeArg funId ix
+            return (L.Argument (ix+1), Just lt)
+
+          C.PreValue pts df -> do
+            pts' <- forM pts $ \(pfxs, lv) -> do
+              (lv', _) <- val2lin lv
+              return (map T.pack pfxs, lv')
+            (df', lt) <- val2lin df
+            return (L.Pre pts' df', lt)
+
+          C.Projection v1 lblId -> do
+            (v1', mtyp) <- val2lin v1
+            -- find label index in argument type
+            let Just (C.RecordType rrs) = mtyp
+            let rrs' = [ lid | C.RecordRow lid _ <- rrs ]
+            -- lblIx <- eitherElemIndex lblId rrs'
+            let
+              lblIx = case eitherElemIndex lblId rrs' of
+                Right x -> x
+                Left _ -> 0 -- corresponds to Prelude.False
+            -- lookup lintype for record row
+            let C.RecordRow _ lt = rrs !! lblIx
+            return (L.Projection v1' (L.Ix (lblIx+1)), Just lt)
+
+          C.Selection v1 v2 -> do
+            (v1', t1) <- val2lin v1
+            (v2', t2) <- val2lin v2
+            let Just (C.TableType t11 t12) = t1 -- t11 == t2
+            return (L.Projection v1' v2', Just t12)
+
+          -- C.CommentedValue cmnt lv -> val2lin lv
+          C.CommentedValue cmnt lv -> case cmnt of
+            "impossible" -> val2lin lv >>= \(_, typ) -> return (L.Empty, typ)
+            _ -> val2lin lv
+
+          v -> CMS.lift $ Left $ printf "val2lin not implemented for: %s" (show v)
+
+  -- Invoke code generation
+
+  let e = flip CMS.evalStateT Map.empty $ mapM mkLin lindefs
+  case e of
+    Left err -> raise err
+    Right lins -> do
+      let maybeOptimise = if debug then id else extractStrings
+      let concr = maybeOptimise $ L.Concrete {
+        L.toks = IntMapBuilder.emptyIntMap,
+        L.lins = Map.fromList lins
+      }
+      return (mdi2i modId, concr)
+
+type CodeGen a = CMS.StateT (Map.Map C.LinValue (L.LinFun, Maybe C.LinType)) (Either String) a
+
+-- | Remove ParamAliasDefs by inlining their definitions
+inlineParamAliases :: [C.ParamDef] -> [C.ParamDef]
+inlineParamAliases defs = if null aliases then defs else map rp' pdefs
+  where
+    (aliases,pdefs) = L.partition isParamAliasDef defs
+
+    rp' :: C.ParamDef -> C.ParamDef
+    rp' (C.ParamDef pid pids) = C.ParamDef pid (map rp'' pids)
+    rp' (C.ParamAliasDef _ _) = error "inlineParamAliases called on ParamAliasDef" -- impossible
+
+    rp'' :: C.ParamValueDef -> C.ParamValueDef
+    rp'' (C.Param pid pids) = C.Param pid (map rp''' pids)
+
+    rp''' :: C.ParamId -> C.ParamId
+    rp''' pid = case L.find (\(C.ParamAliasDef p _) -> p == pid) aliases of
+      Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p
+      _ -> pid
+
+-- | 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 Text) (Map.Map CId L.LinFun)
+    go0 mp = do
+      xs <- mapM (\(cid,lin) -> go lin >>= \lin' -> return (cid,lin')) (Map.toList mp)
+      return $ Map.fromList xs
+
+    go :: L.LinFun -> CMS.State (IntMapBuilder.IMB Text) L.LinFun
+    go lf = case lf of
+      L.Token str -> do
+        imb <- CMS.get
+        let (ix,imb') = IntMapBuilder.insert' str imb
+        CMS.put imb'
+        return $ L.TokenIx ix
+
+      L.Pre pts df -> do
+        -- pts' <- mapM (\(pfxs,lv) -> go lv >>= \lv' -> return (pfxs,lv')) pts
+        pts' <- forM pts $ \(pfxs,lv) -> do
+          imb <- CMS.get
+          let str = T.pack $ show pfxs
+          let (ix,imb') = IntMapBuilder.insert' str imb
+          CMS.put imb'
+          lv' <- go lv
+          return (ix,lv')
+        df' <- go df
+        return $ L.PreIx pts' df'
+      L.Concat s t -> do
+        s' <- go s
+        t' <- go t
+        return $ L.Concat s' t'
+      L.Tuple ts -> do
+        ts' <- mapM go ts
+        return $ L.Tuple ts'
+      L.Projection t u -> do
+        t' <- go t
+        u' <- go u
+        return $ L.Projection t' u'
+      t -> return t
+
+-- | Convert Maybe to Either value with error
+m2e :: String -> Maybe a -> Either String a
+m2e err = maybe (Left err) Right
+
+-- | Wrap elemIndex into Either value
+eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
+eitherElemIndex x xs = m2e (printf "Cannot find: %s in %s" (show x) (show xs)) (elemIndex x xs)
+
+mdi2s :: C.ModId -> String
+mdi2s (C.ModId i) = 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

@@ -1,14 +1,17 @@
-{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts, MagicHash #-}
-module GF.Compile.GrammarToPGF (grammar2PGF) where
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+module GF.Compile.GrammarToPGF (mkCanon2pgf) where
 
+--import GF.Compile.Export
 import GF.Compile.GeneratePMCFG
 import GF.Compile.GenerateBC
-import GF.Compile.OptimizePGF
 
-import PGF2 hiding (mkType)
-import PGF2.Internal
+import PGF(CId,mkCId,utf8CId)
+import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
+import PGF.Internal(updateProductionIndices)
+import qualified PGF.Internal as C
+import qualified PGF.Internal as D
 import GF.Grammar.Predef
-import GF.Grammar.Grammar hiding (Production)
+import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look
 import qualified GF.Grammar as A
 import qualified GF.Grammar.Macros as GM
@@ -19,141 +22,111 @@ import GF.Infra.UseIO (IOE)
 import GF.Data.Operations
 
 import Data.List
-import Data.Char
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
 import Data.Array.IArray
-import Data.Maybe(fromMaybe)
 
-import GHC.Prim
-import GHC.Base(getTag)
 
-grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
-grammar2PGF opts gr am probs = do
-  cnc_infos <- getConcreteInfos gr am
-  return $
-    build (let gflags   = if flag optSplitPGF opts 
-                            then [("split", LStr "true")]
-                            else []
-               (an,abs) = mkAbstr am probs
-               cncs     = map (mkConcr opts abs) cnc_infos
-           in newPGF gflags an abs cncs)
+mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
+mkCanon2pgf opts gr am = do
+  (an,abs) <- mkAbstr am
+  cncs     <- mapM mkConcr (allConcretes gr am)
+  return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
   where
     cenv = resourceValues opts gr
-    aflags = err (const noOptions) mflags (lookupModule gr am)
 
-    mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map PGF2.Fun Double -> (AbsName, B s AbstrInfo)
-    mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
+    mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
       where
+        aflags = err (const noOptions) mflags (lookupModule gr am)
+
         adefs =
             [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
             Look.allOrigInfos gr am
 
-        flags = optionsPGF aflags
+        flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
 
-        toLogProb = realToFrac . negate . log
-
-        cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
-                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
-
-        funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
+        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | 
                                    ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
-                                   let arity = mkArity ma mdef ty,
-                                   let bcode = mkDef gr arity mdef,
-                                   let f' = i2i f]
-                                   
-        funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
-                        [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
-                                                                   let (_,(_,cat),_) = GM.typeForm ty,
-                                                                   let f' = i2i f]
-          where
-            pad :: [(a,Maybe Double)] -> [(a,Double)]
-            pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
-              where
-                deflt = case length [f | (f,Nothing) <- pfs] of
-                          0 -> 0
-                          n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
+                                   let arity = mkArity ma mdef ty]
 
-    mkConcr opts abs (cm,ex_seqs,cdefs) =
+        cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
+                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs]
+
+        catfuns cat =
+              [(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)
           ciCmp | flag optCaseSensitive cflags = compare
-                | otherwise                    = compareCaseInsensitive
+                | otherwise                    = C.compareCaseInsensitve
 
-          flags = optionsPGF aflags
+      (ex_seqs,cdefs) <- addMissingPMCFGs
+                            Map.empty 
+                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
+                             Look.allOrigInfos gr cm)
 
-          seqs = (mkSetArray . Set.fromList . concat) $
-                       (elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
+      let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]
+
+          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
-          cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
           !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
-                                = genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt1 cnccat_ranges
+                                = genCncFuns gr am cm ex_seqs_arr ciCmp seqs cdefs fid_cnt1 cnccats
 
           printnames = genPrintNames cdefs
-
-          startCat = (fromMaybe "S" (flag optStartCat aflags))
-
-          (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
-               (if flag optOptimizePGF opts then optimizePGF startCat else id)
-                    (lindefs,linrefs,productions,cncfuns,elems seqs,cnccats)
-
-      in (mi2i cm, newConcr abs
-                            flags
-                            printnames
-                            lindefs'
-                            linrefs'
-                            productions'
-                            cncfuns'
-                            sequences'
-                            cnccats'
-                            fid_cnt2)
-
-    getConcreteInfos gr am = mapM flatten (allConcretes gr am)
+      return (mi2i cm, D.Concr flags
+                              printnames
+                              cncfuns
+                              lindefs
+                              linrefs
+                              seqs
+                              productions
+                              IntMap.empty
+                              Map.empty
+                              cnccats
+                              IntMap.empty
+                              fid_cnt2)
       where
-        flatten cm = do
-          (seqs,infos) <- addMissingPMCFGs cm Map.empty
-                                           (lit_infos ++ Look.allOrigInfos gr cm)
-          return (cm,mkMapArray seqs :: Array SeqId [Symbol],infos)
-
-        lit_infos = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]]
-
         -- if some module was compiled with -no-pmcfg, then
         -- we have to create the PMCFG code just before linking
-        addMissingPMCFGs cm seqs []                  = return (seqs,[])
-        addMissingPMCFGs cm seqs (((m,id), info):is) = do
-          (seqs,info)  <- addPMCFG opts gr cenv Nothing am cm seqs id info
-          (seqs,infos) <- addMissingPMCFGs cm seqs is
-          return (seqs, ((m,id), info) : infos)
+        addMissingPMCFGs seqs []                  = return (seqs,[])
+        addMissingPMCFGs seqs (((m,id), info):is) = do
+          (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
+          (seqs,is  ) <- addMissingPMCFGs seqs is
+          return (seqs, ((m,id), info) : is)
 
-i2i :: Ident -> String
-i2i = showIdent
+i2i :: Ident -> CId
+i2i = utf8CId . ident2utf8
 
-mi2i :: ModuleName -> String
+mi2i :: ModuleName -> CId
 mi2i (MN i) = i2i i
 
-mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF2.Type
+mkType :: [Ident] -> A.Type -> C.Type
 mkType scope t =
   case GM.typeForm t of
     (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
-                           in dTyp hyps' (i2i cat) (map (mkExp scope') args)
+                           in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
 
-mkExp :: (?builder :: Builder s) => [Ident] -> A.Term -> B s Expr
-mkExp scope t =
+mkExp :: [Ident] -> A.Term -> C.Expr
+mkExp scope t = 
   case t of
-    Q (_,c)  -> eFun (i2i c)
-    QC (_,c) -> eFun (i2i c)
+    Q (_,c)  -> C.EFun (i2i c)
+    QC (_,c) -> C.EFun (i2i c)
     Vr x     -> case lookup x (zip scope [0..]) of
-                  Just i  -> eVar  i
-                  Nothing -> eMeta 0
-    Abs b x t-> eAbs b (i2i x) (mkExp (x:scope) t)
-    App t1 t2-> eApp (mkExp scope t1) (mkExp scope t2)
-    EInt i   -> eLit (LInt (fromIntegral i))
-    EFloat f -> eLit (LFlt f)
-    K s      -> eLit (LStr s)
-    Meta i   -> eMeta i
-    _        -> eMeta 0
-{-
+                  Just i  -> C.EVar  i
+                  Nothing -> C.EMeta 0
+    Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
+    App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
+    EInt i   -> C.ELit (C.LInt (fromIntegral i))
+    EFloat f -> C.ELit (C.LFlt f)
+    K s      -> C.ELit (C.LStr s)
+    Meta i   -> C.EMeta i
+    _        -> C.EMeta 0
+
 mkPatt scope p = 
   case p of
     A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
@@ -168,64 +141,67 @@ mkPatt scope p =
     A.PImplArg p-> let (scope',p') = mkPatt scope p
                    in (scope',C.PImplArg p')
     A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
--}
-mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF2.Hypo])
+
+mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
 mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                       in if x == identW
-                                                           then (  scope,hypo bt (i2i x) ty')
-                                                           else (x:scope,hypo bt (i2i x) ty')) scope hyps 
+                                                           then (  scope,(bt,i2i x,ty'))
+                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps 
 
-mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
-mkDef gr arity Nothing    = []
+mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
+                                 ,generateByteCode gr arity eqs
+                                 )
+mkDef gr arity Nothing    = Nothing
 
 mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
 mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
 mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
                                in length ctxt
 
-genCncCats gr am cm cdefs = mkCncCats 0 cdefs
+genCncCats gr am cm cdefs =
+  let (index,cats) = mkCncCats 0 cdefs
+  in (index, Map.fromList cats)
   where
     mkCncCats index []                                                = (index,[])
     mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
       | id == cInt    = 
-            let cc            = pgfCncCat gr (i2i id) lincat fidInt
+            let cc            = pgfCncCat gr lincat fidInt
                 (index',cats) = mkCncCats index cdefs
-            in (index', cc : cats)
+            in (index', (i2i id,cc) : cats)
       | id == cFloat  = 
-            let cc            = pgfCncCat gr (i2i id) lincat fidFloat
+            let cc            = pgfCncCat gr lincat fidFloat
                 (index',cats) = mkCncCats index cdefs
-            in (index', cc : cats)
+            in (index', (i2i id,cc) : cats)
       | id == cString = 
-            let cc            = pgfCncCat gr (i2i id) lincat fidString
+            let cc            = pgfCncCat gr lincat fidString
                 (index',cats) = mkCncCats index cdefs
-            in (index', cc : cats)
+            in (index', (i2i id,cc) : cats)
       | otherwise     =
-            let cc@(_, _s, e, _) = pgfCncCat gr (i2i id) lincat index
-                (index',cats)    = mkCncCats (e+1) cdefs
-            in (index', cc : cats)
-    mkCncCats index (_                                          :cdefs) = mkCncCats index cdefs
+            let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index
+                (index',cats)        = mkCncCats (e+1) cdefs
+            in (index', (i2i id,cc) : cats)
+    mkCncCats index (_                      :cdefs) = mkCncCats index cdefs
 
 genCncFuns :: Grammar
            -> ModuleName
            -> ModuleName
-           -> Array SeqId [Symbol]
-           -> ([Symbol] -> [Symbol] -> Ordering)
-           -> Array SeqId [Symbol]
+           -> Array SeqId Sequence
+           -> (Sequence -> Sequence -> Ordering)
+           -> Array SeqId Sequence
            -> [(QIdent, Info)]
            -> FId
-           -> Map.Map PGF2.Cat (Int,Int)
+           -> Map.Map CId D.CncCat
            -> (FId,
-               [(FId, [Production])],
-               [(FId, [FunId])],
-               [(FId, [FunId])],
-               [(PGF2.Fun,[SeqId])])
-genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
+               IntMap.IntMap (Set.Set D.Production),
+               IntMap.IntMap [FunId],
+               IntMap.IntMap [FunId],
+               Array FunId D.CncFun)
+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,prods0)          = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
-      prods                                      = [(fid,Set.toList prodSet) | (fid,prodSet) <- IntMap.toList prods0]
-  in (fid_cnt2,prods,IntMap.toList lindefs,IntMap.toList linrefs,reverse funs2)
+      (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)
   where
-    mkCncCats []                                                          fid_cnt funs_cnt funs lindefs linrefs =
+    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
       (fid_cnt,funs_cnt,funs,lindefs,linrefs)
     mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
       let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
@@ -234,16 +210,17 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
           linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
           funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
       in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
-    mkCncCats (_                                                  :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
+    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
       mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
 
     mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
       (fid_cnt,funs_cnt,funs,prods)
     mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
-      let ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
+      let ---Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
+          ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
           !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
                            in funs_cnt+(e_funid-s_funid+1)
-          !(fid_cnt',crc',prods')
+          !(fid_cnt',crc',prods') 
                          = foldl' (toProd lindefs ty_C funs_cnt)
                                   (fid_cnt,crc,prods) prods0
           funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
@@ -251,23 +228,23 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
     mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt funs lindefs crc prods = 
       mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
 
-    toProd lindefs (ctxt_C,res_C,_) offs st (A.Production fid0 funid0 args0) =
-      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0)
-          set0    = Set.fromList (map (PApply (offs+funid0)) (sequence args))
+    toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
+      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) 
+          set0    = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
           fid     = mkFId res_C fid0
           !prods' = case IntMap.lookup fid prods of
                      Just set -> IntMap.insert fid (Set.union set0 set) prods
                      Nothing  -> IntMap.insert fid set0 prods
       in (fid_cnt,crc,prods')
       where
-        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) =
+        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
           case fid0s of
-            [fid0] -> (st,map (flip PArg (mkFId arg_C fid0)) ctxt)
+            [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
             fid0s  -> case Map.lookup fids crc of
-                        Just fid -> (st,map (flip PArg fid) ctxt)
+                        Just fid -> (st,map (flip C.PArg fid) ctxt)
                         Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
-                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map PCoerce fids)) prods
-                                    in ((fid_cnt+1,crc',prods'),map (flip PArg fid_cnt) ctxt)
+                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
+                                    in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
           where
             (hargs_C,arg_C) = GM.catSkeleton ty
             ctxt = mapM (mkCtxt lindefs) hargs_C
@@ -275,14 +252,14 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
 
     mkLinDefId id = prefixIdent "lindef " id
 
-    toLinDef res offs lindefs (A.Production fid0 funid0 args) =
+    toLinDef res offs lindefs (Production fid0 funid0 args) =
       if args == [[fidVar]]
         then IntMap.insertWith (++) fid [offs+funid0] lindefs
         else lindefs
       where
         fid = mkFId res fid0
 
-    toLinRef res offs linrefs (A.Production fid0 funid0 [fargs]) =
+    toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
       if fid0 == fidVar
         then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
         else linrefs
@@ -290,20 +267,20 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
         fids = map (mkFId res) fargs
 
     mkFId (_,cat) fid0 =
-      case Map.lookup (i2i cat) cnccat_ranges of
-        Just (s,e) -> s+fid0
-        Nothing    -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
+      case Map.lookup (i2i cat) cnccats of
+        Just (C.CncCat s e _) -> s+fid0
+        Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
 
     mkCtxt lindefs (_,cat) =
-      case Map.lookup (i2i cat) cnccat_ranges of
-        Just (s,e) -> [(fid,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
-        Nothing    -> error "GrammarToPGF.mkCtxt failed"
+      case Map.lookup (i2i cat) cnccats of
+        Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
+        Nothing               -> error "GrammarToPGF.mkCtxt failed"
 
     toCncFun offs (m,id) funs (funid0,lins0) =
       let mseqs = case lookupModule gr m of
                     Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
                     _                              -> ex_seqs
-      in (i2i id, map (newIndex mseqs) (elems lins0)):funs
+      in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs                                          
       where
         newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
 
@@ -316,9 +293,8 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
           where
             k = (i+j) `div` 2
 
-
 genPrintNames cdefs =
-  [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
+  Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
   where
     prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
     prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
@@ -330,118 +306,3 @@ genPrintNames cdefs =
 
 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) (Set.toList set)
-
--- The following is a version of Data.List.sortBy which together
--- with the sorting also eliminates duplicate values 
-sortNubBy cmp = mergeAll . sequences
-  where
-    sequences (a:b:xs) =
-      case cmp a b of
-        GT -> descending b [a]  xs
-        EQ -> sequences (b:xs)
-        LT -> ascending  b (a:) xs
-    sequences xs = [xs]
-
-    descending a as []     = [a:as]
-    descending a as (b:bs) =
-      case cmp a b of
-        GT -> descending b (a:as) bs
-        EQ -> descending a as bs
-        LT -> (a:as) : sequences (b:bs)
-
-    ascending a as []     = let !x = as [a]
-                            in [x]
-    ascending a as (b:bs) =
-      case cmp a b of
-        GT -> let !x = as [a]
-              in x : sequences (b:bs)
-        EQ -> ascending a as bs
-        LT -> ascending b (\ys -> as (a:ys)) bs
-
-    mergeAll [x] = x
-    mergeAll xs  = mergeAll (mergePairs xs)
-
-    mergePairs (a:b:xs) = let !x = merge a b
-                          in x : mergePairs xs
-    mergePairs xs       = xs
-
-    merge as@(a:as') bs@(b:bs') =
-      case cmp a b of
-        GT -> b:merge as  bs'
-        EQ -> a:merge as' bs'
-        LT -> a:merge as' bs
-    merge [] bs         = bs
-    merge as []         = as
-
--- The following function does case-insensitive comparison of sequences.
--- This is used to allow case-insensitive parsing, while
--- the linearizer still has access to the original cases.
-
-compareCaseInsensitive []     []     = EQ
-compareCaseInsensitive []     _      = LT
-compareCaseInsensitive _      []     = GT
-compareCaseInsensitive (x:xs) (y:ys) =
-  case compareSym x y of
-    EQ -> compareCaseInsensitive xs ys
-    x  -> x
-  where
-    compareSym s1 s2 =
-      case s1 of
-        SymCat d1 r1
-          -> case s2 of
-               SymCat d2 r2
-                 -> case compare d1 d2 of
-                      EQ -> r1 `compare` r2
-                      x  -> x
-               _ -> LT
-        SymLit d1 r1
-          -> case s2 of
-               SymCat {} -> GT
-               SymLit d2 r2
-                 -> case compare d1 d2 of
-                      EQ -> r1 `compare` r2
-                      x  -> x
-               _ -> LT
-        SymVar d1 r1
-          -> if tagToEnum# (getTag s2 ># 2#)
-               then LT
-               else case s2 of
-                      SymVar d2 r2
-                        -> case compare d1 d2 of
-                             EQ -> r1 `compare` r2
-                             x  -> x
-                      _ -> GT
-        SymKS t1
-          -> if tagToEnum# (getTag s2 ># 3#)
-               then LT
-               else case s2 of
-                      SymKS t2 -> t1 `compareToken` t2
-                      _          -> GT
-        SymKP a1 b1
-          -> if tagToEnum# (getTag s2 ># 4#)
-               then LT
-               else case s2 of
-                      SymKP a2 b2
-                        -> case compare a1 a2 of
-                             EQ -> b1 `compare` b2
-                             x  -> x
-                      _ -> GT
-        _ -> let t1 = getTag s1
-                 t2 = getTag s2
-             in if tagToEnum# (t1 <# t2) 
-                  then LT
-                  else if tagToEnum# (t1 ==# t2)
-                         then EQ
-                         else GT
-  
-    compareToken []     []     = EQ
-    compareToken []     _      = LT
-    compareToken _      []     = GT
-    compareToken (x:xs) (y:ys)
-      | x == y    = compareToken xs ys
-      | otherwise = case compare (toLower x) (toLower y) of
-                      EQ -> case compareToken xs ys of
-                              EQ -> compare x y
-                              x  -> x
-                      x  -> x

src/compiler/GF/Compile/OptimizePGF.hs

@@ -1,189 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module GF.Compile.OptimizePGF(optimizePGF) where
-
-import PGF2(Cat,Fun)
-import PGF2.Internal
-import Data.Array.ST
-import Data.Array.Unboxed
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.IntSet as IntSet
-import qualified Data.IntMap as IntMap
-import qualified Data.List as List
-import Control.Monad.ST
-
-type ConcrData = ([(FId,[FunId])],          -- ^ Lindefs
-                  [(FId,[FunId])],          -- ^ Linrefs
-                  [(FId,[Production])],     -- ^ Productions
-                  [(Fun,[SeqId])],          -- ^ Concrete functions   (must be sorted by Fun)
-                  [[Symbol]],               -- ^ Sequences            (must be sorted)
-                  [(Cat,FId,FId,[String])]) -- ^ Concrete categories
-
-optimizePGF :: Cat -> ConcrData -> ConcrData
-optimizePGF startCat = topDownFilter startCat . bottomUpFilter
-
-catString = "String"
-catInt    = "Int"
-catFloat  = "Float"
-catVar    = "__gfVar"
-
-topDownFilter :: Cat -> ConcrData -> ConcrData
-topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
-  let env0             = (Map.empty,Map.empty)
-      (env1,lindefs')  = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fid [PArg [] fidVar]) env funids in (env',(fid,funids')))
-                                        env0
-                                        lindefs
-      (env2,linrefs')  = List.mapAccumL (\env (fid,funids) -> let (env',funids') = List.mapAccumL (optimizeFun fidVar [PArg [] fid]) env funids in (env',(fid,funids')))
-                                        env1
-                                        linrefs
-      (env3,prods')    = List.mapAccumL (\env (fid,set)    -> let (env',set') = List.mapAccumL (optimizeProd fid) env set in (env',(fid,set')))
-                                        env2
-                                        prods
-      cnccats' = map filterCatLabels cnccats
-      (sequences',cncfuns') = env3
-  in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray  sequences',cnccats')
-  where
-    cncfuns_array   = listArray (0,length cncfuns-1)   cncfuns   :: Array FunId (Fun, [SeqId])
-    sequences_array = listArray (0,length sequences-1) sequences :: Array SeqId [Symbol]
-    prods_map  = IntMap.fromList prods
-    fid2catMap = IntMap.fromList ((fidVar,catVar) :  [(fid,cat) | (cat,start,end,lbls) <- cnccats,
-                                                                  fid <- [start..end]])
-
-    fid2cat fid =
-      case IntMap.lookup fid fid2catMap of
-        Just cat -> cat
-        Nothing  -> case [fid | Just set <- [IntMap.lookup fid prods_map], PCoerce fid <- set] of
-                      (fid:_) -> fid2cat fid
-                      _       -> error "unknown forest id"
-
-    starts =
-      [(startCat,lbl) | (cat,_,_,lbls) <- cnccats, cat==startCat, lbl <- [0..length lbls-1]]
-
-    allRelations =
-      Map.unionsWith Set.union
-                     [rel fid prod | (fid,set) <- prods, prod <- set]
-      where
-        rel fid (PApply funid args) = Map.fromList [((fid2cat fid,lbl),deps args seqid) | (lbl,seqid) <- zip [0..] lin]
-          where
-            (_,lin) = cncfuns_array ! funid
-        rel fid _                   = Map.empty
-
-        deps args seqid = Set.fromList [let PArg _ fid = args !! r in (fid2cat fid,d) | SymCat r d <- seq]
-          where
-            seq = sequences_array ! seqid
-
-    -- here we create a mapping from a category to an array of indices.
-    -- An element of the array is equal to -1 if the corresponding index
-    -- is not going to be used in the optimized grammar, or the new index
-    -- if it will be used
-    closure :: Map.Map Cat [Int]
-    closure = runST $ do
-      set <- initSet
-      addLitCat catString set
-      addLitCat catInt    set
-      addLitCat catFloat  set
-      addLitCat catVar    set
-      closureSet set starts
-      doneSet set
-      where
-        initSet :: ST s (Map.Map Cat (STUArray s Int Int))
-        initSet =
-          fmap Map.fromList $ sequence
-                        [fmap ((,) cat) (newArray (0,length lbls-1) (-1))
-                                             | (cat,_,_,lbls) <- cnccats]
-
-        addLitCat cat set =
-          case Map.lookup cat set of
-            Just indices -> writeArray indices 0 0
-            Nothing      -> return ()
-
-        closureSet set []                 = return ()
-        closureSet set (x@(cat,index):xs) =
-          case Map.lookup cat set of
-            Just indices -> do v <- readArray indices index
-                               writeArray indices index 0
-                               if v < 0
-                                 then case Map.lookup x allRelations of
-                                        Just ys -> closureSet set (Set.toList ys++xs)
-                                        Nothing -> closureSet set xs
-                                 else closureSet set xs
-            Nothing      -> error "unknown cat"
-
-        doneSet :: Map.Map Cat (STUArray s Int Int) -> ST s (Map.Map Cat [Int])
-        doneSet set =
-          fmap Map.fromAscList $ mapM done (Map.toAscList set)
-          where
-            done (cat,indices) = do
-              indices <- fmap (reindex 0) (getElems indices)
-              return (cat,indices)
-
-            reindex k []     = []
-            reindex k (v:vs)
-              | v < 0        = v : reindex k     vs
-              | otherwise    = k : reindex (k+1) vs
-
-    optimizeProd res env (PApply funid args) =
-      let (env',funid') = optimizeFun res args env funid
-      in (env', PApply funid' args)
-    optimizeProd res env prod = (env,prod)
-
-    optimizeFun res args (seqs,funs) funid =
-      let (seqs',lin')   = List.mapAccumL addUnique seqs [map updateSymbol (sequences_array ! seqid) | 
-                                                                   (idx,seqid) <- zip (indicesOf res) lin, idx >= 0]
-          (funs',funid') = addUnique funs (fun, lin')
-      in ((seqs',funs'), funid')
-      where
-        (fun,lin) = cncfuns_array ! funid
-
-        indicesOf fid
-          | fid < 0   = [0]
-          | otherwise =
-              case Map.lookup (fid2cat fid) closure of
-                Just indices -> indices
-                Nothing      -> error "unknown category"
-
-        addUnique seqs seq =
-          case Map.lookup seq seqs of
-            Just seqid -> (seqs,seqid)
-            Nothing    -> let seqid = Map.size seqs
-                          in (Map.insert seq seqid seqs, seqid)
-
-        updateSymbol (SymCat r d) = let PArg _ fid = args !! r in SymCat r (indicesOf fid !! d)
-        updateSymbol s            = s
-
-    filterCatLabels (cat,start,end,lbls) =
-      case Map.lookup cat closure of
-        Just indices -> let lbls' = [lbl | (idx,lbl) <- zip indices lbls, idx >= 0]
-                        in (cat,start,end,lbls')
-        Nothing      -> error ("unknown category")
-
-    mkSetArray map = sortSnd (Map.toList map)
-      where
-        sortSnd = List.map fst . List.sortBy (\(_,i) (_,j) -> compare i j)
-
-
-bottomUpFilter :: ConcrData -> ConcrData
-bottomUpFilter (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
-  (lindefs,linrefs,filterProductions IntMap.empty IntSet.empty prods,cncfuns,sequences,cnccats)
-
-filterProductions prods0 hoc0 prods
-  | prods0 == prods1 = IntMap.toList prods0
-  | otherwise        = filterProductions prods1 hoc1 prods
-  where
-    (prods1,hoc1) = foldl foldProdSet (IntMap.empty,IntSet.empty) prods
-
-    foldProdSet (!prods,!hoc) (fid,set)
-      | null set1 = (prods,hoc)
-      | otherwise = (IntMap.insert fid set1 prods,hoc1)
-      where
-        set1 = filter filterRule set
-        hoc1 = foldl accumHOC hoc set1
-
-    filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args
-    filterRule (PCoerce fid)       = isLive fid
-    filterRule _                   = True
-
-    isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0
-
-    accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
-    accumHOC hoc _                   = hoc

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -16,61 +16,68 @@
 
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
-import PGF2
-import PGF2.Internal
+import PGF(showCId)
+import PGF.Internal
 
 import GF.Data.Operations
 import GF.Infra.Option
 
-import Data.List
-import Data.Maybe(mapMaybe)
+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 (++++) [] $  
-  pragmas ++ haskPreamble gadt name ++ [types, gfinstances gId lexical gr'] ++ compos
+grammar2haskell opts name gr = foldr (++++) [] $
+  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
-              | otherwise = ("G"++)
-          pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"]
+          gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
+              | otherwise = ("G"++) . rmForbiddenChars
+          -- GF grammars allow weird identifier names inside '', e.g. 'VP/Object'
+          rmForbiddenChars = filter (`notElem` "'!#$%&*+./<=>?@\\^|-~")
+          pragmas | gadt = ["{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"]
+                  | dataExt = ["{-# LANGUAGE DeriveDataTypeable #-}"]
                   | otherwise = []
+          derivingClause
+                 | dataExt = "deriving (Show,Data)"
+                 | otherwise = "deriving Show"
+          extraImports | gadt = ["import Control.Monad.Identity",
+                                 "import Data.Monoid"]
+                       | dataExt = ["import Data.Data"]
+                       | otherwise = []
           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",
   ""
- ] ++
- (if gadt then [
-  "import Control.Monad.Identity",
-  "import Data.Monoid"
-  ] else []) ++
- [
+ ] ++ extraImports ++ [
   "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",
@@ -78,11 +85,11 @@ haskPreamble gadt name =
   ""
  ]
 
-predefInst gadt gtyp typ destr consr = 
+predefInst gadt derivingClause gtyp typ destr consr =
   (if gadt
-    then [] 
-    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show\n\n") 
-    ) 
+    then []
+    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
+    )
   ++
   "instance Gf" +++ gtyp +++ "where" ++++
   "  gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
@@ -95,24 +102,24 @@ type OIdent = String
 
 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 
-datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd
+datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
+datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
 
 gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
 gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
 
 
-hDatatype  :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
-hDatatype _ _ ("Cn",_) = "" ---
-hDatatype gId _ (cat,[]) = "data" +++ gId cat
-hDatatype gId _ (cat,rules) | isListCat (cat,rules) = 
- "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" 
-  +++ "deriving Show"
-hDatatype gId lexical (cat,rules) =
+hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
+hDatatype _ _ _ ("Cn",_) = "" ---
+hDatatype gId _ _ (cat,[]) = "data" +++ gId cat
+hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) =
+ "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+  +++ derivingClause
+hDatatype gId derivingClause lexical (cat,rules) =
  "data" +++ gId cat +++ "=" ++
  (if length rules == 1 then "" else "\n  ") +++
  foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
- "  deriving Show"
+ " " +++ derivingClause
   where
     constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
                    ++ if lexical cat then [lexicalConstructor cat +++ "String"] else []
@@ -242,7 +249,7 @@ fInstance gId lexical m (cat,rules) =
     then "    " ++ gId cat ++ " (fgs t) where\n     fgs t = case unApp t of"
     else "    case unApp t of") ++++
   unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
-  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
+  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "(showCId i)" else "") ++++
   "      _ -> error (\"no" +++ cat ++ " \" ++ show t)"
    where
     isList = isListCat (cat,rules)
@@ -263,21 +270,18 @@ fInstance gId lexical m (cat,rules) =
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
 hSkeleton gr = 
-  (abstractName gr,
+  (showCId (absname gr), 
    let fs = 
-         [(c, [(f, cs) | (f, cs,_) <- fs]) | 
-                                        fs@((_, _,c):_) <- fns]
-   in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
+         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | 
+                                        fs@((_, (_,c)):_) <- fns]
+   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
-   cts = categories gr
-   fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
-   valtyps (_,_,x) (_,_,y) = compare x y
-   valtypg (_,_,x) (_,_,y) = x == y
-   jty f = case functionType gr f of
-             Just ty -> let (hypos,valcat,_) = unType ty
-                        in Just (f,[argcat | (_,_,ty) <- hypos, let (_,argcat,_) = unType ty],valcat)
-             Nothing -> Nothing
+   cts = Map.keys (cats (abstract gr)) 
+   fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
+   valtyps (_, (_,x)) (_, (_,y)) = compare x y
+   valtypg (_, (_,x)) (_, (_,y)) = x == y
+   jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
 {-
 updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
 updateSkeleton cat skel rule =

src/compiler/GF/Compile/PGFtoJS.hs

@@ -0,0 +1,105 @@
+module GF.Compile.PGFtoJS (pgf2js) where
+
+import PGF(showCId)
+import PGF.Internal as M
+import qualified GF.JavaScript.AbsJS as JS
+import qualified GF.JavaScript.PrintJS as JS
+
+--import GF.Data.ErrM
+--import GF.Infra.Option
+
+--import Control.Monad (mplus)
+--import Data.Array.Unboxed (UArray)
+import qualified Data.Array.IArray as Array
+--import Data.Maybe (fromMaybe)
+import Data.Map (Map)
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+
+pgf2js :: PGF -> String
+pgf2js pgf =
+  JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
+ where
+   n  = showCId $ absname pgf
+   as = abstract pgf
+   cs = Map.assocs (concretes pgf)
+   start = showCId $ M.lookStartCat pgf
+   grammar = new "GFGrammar" [js_abstract, js_concrete]
+   js_abstract = abstract2js start as
+   js_concrete = JS.EObj $ map concrete2js cs
+
+abstract2js :: String -> Abstr -> JS.Expr
+abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
+
+absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
+absdef2js (f,(typ,_,_,_)) =
+  let (args,cat) = M.catSkeleton typ in 
+    JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
+
+lit2js (LStr s) = JS.EStr s
+lit2js (LInt n) = JS.EInt n
+lit2js (LFlt d) = JS.EDbl d
+
+concrete2js :: (CId,Concr) -> JS.Property
+concrete2js (c,cnc) =
+  JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ cflags cnc,
+                               JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)],
+                               JS.EArray $ (map ffun2js (Array.elems (cncfuns cnc))),
+                               JS.EArray $ (map seq2js (Array.elems (sequences cnc))),
+                               JS.EObj $ map cats (Map.assocs (cnccats cnc)),
+                               JS.EInt (totalCats cnc)])
+  where 
+   l  = JS.IdentPropName (JS.Ident (showCId c))
+{-
+   litslins = [JS.Prop (JS.StringPropName    "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), 
+               JS.Prop (JS.StringPropName  "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
+               JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
+-}
+   cats (c,CncCat start end _) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start)
+                                                                                            ,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)])
+{-
+mkStr :: String -> JS.Expr
+mkStr s = new "Str" [JS.EStr s]
+
+mkSeq :: [JS.Expr] -> JS.Expr
+mkSeq [x] = x
+mkSeq xs = new "Seq" xs
+
+argIdent :: Integer -> JS.Ident
+argIdent n = JS.Ident ("x" ++ show n)
+-}
+children :: JS.Ident
+children = JS.Ident "cs"
+
+frule2js :: Production -> JS.Expr
+frule2js (PApply funid args) = new "Apply"  [JS.EInt funid, JS.EArray (map farg2js args)]
+frule2js (PCoerce arg)       = new "Coerce" [JS.EInt arg]
+
+farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid])
+
+ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))]
+
+seq2js :: Array.Array DotPos Symbol -> JS.Expr
+seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq]
+
+sym2js :: Symbol -> JS.Expr
+sym2js (SymCat n l)    = new "SymCat" [JS.EInt n, JS.EInt l]
+sym2js (SymLit n l)    = new "SymLit" [JS.EInt n, JS.EInt l]
+sym2js (SymVar n l)    = new "SymVar" [JS.EInt n, JS.EInt l]
+sym2js (SymKS t)       = new "SymKS"  [JS.EStr t]
+sym2js (SymKP ts alts) = new "SymKP"  [JS.EArray (map sym2js ts), JS.EArray (map alt2js alts)]
+sym2js SymBIND         = new "SymKS"  [JS.EStr "&+"]
+sym2js SymSOFT_BIND    = new "SymKS"  [JS.EStr "&+"]
+sym2js SymSOFT_SPACE   = new "SymKS"  [JS.EStr "&+"]
+sym2js SymCAPIT        = new "SymKS"  [JS.EStr "&|"]
+sym2js SymALL_CAPIT    = new "SymKS"  [JS.EStr "&|"]
+sym2js SymNE           = new "SymNE"  []
+
+alt2js (ps,ts) = new "Alt" [JS.EArray (map sym2js ps), JS.EArray (map JS.EStr ts)]
+
+new :: String -> [JS.Expr] -> JS.Expr
+new f xs = JS.ENew (JS.Ident f) xs
+
+mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
+mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]

src/compiler/GF/Compile/PGFtoJSON.hs

@@ -1,110 +1,156 @@
 module GF.Compile.PGFtoJSON (pgf2json) where
 
-import PGF2
-import PGF2.Internal
-import Text.JSON
+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 =
-  encode $ makeObj
-    [ ("abstract", abstract2json pgf)
-    , ("concretes", makeObj $ map concrete2json
-                                (Map.toList (languages 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)))
     ]
 
-abstract2json :: PGF -> JSValue
-abstract2json pgf =
-  makeObj
-    [ ("name", showJSON (abstractName pgf))
-    , ("startcat", showJSON (showType [] (startCat pgf)))
-    , ("funs", makeObj $ map (absdef2json pgf) (functions pgf))
-    ]
-
-absdef2json :: PGF -> Fun -> (String,JSValue)
-absdef2json pgf f = (f,sig)
+absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
+absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
   where
-    Just (hypos,cat,_) = fmap unType (functionType pgf f)
-    sig = makeObj
-      [ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
-      , ("cat", showJSON cat)
+    (args,cat) = M.catSkeleton typ
+    sig = JSON.makeObj
+      [ ("args", JSArray $ map (mkJSStr.showCId) args)
+      , ("cat", mkJSStr $ showCId cat)
       ]
 
 lit2json :: Literal -> JSValue
-lit2json (LStr s) = showJSON s
-lit2json (LInt n) = showJSON n
-lit2json (LFlt d) = showJSON d
+lit2json (LStr s) = mkJSStr s
+lit2json (LInt n) = mkJSInt n
+lit2json (LFlt d) = JSRational True (toRational d)
 
-concrete2json :: (ConcName,Concr) -> (String,JSValue)
-concrete2json (c,cnc) = (c,obj)
+concrete2json :: (CId,Concr) -> (String,JSValue)
+concrete2json (c,cnc) = (showCId c,obj)
   where
-    obj = makeObj
-      [ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc])
-      , ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]])
-      , ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]])
-      , ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]])
-      , ("categories", makeObj $ map cat2json (concrCategories cnc))
-      , ("totalfids", showJSON (concrTotalCats cnc))
+    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))
       ]
 
-cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
-cat2json (cat,start,end,_) = (cat, ixs)
+cats2json :: (CId, CncCat) -> (String,JSValue)
+cats2json (c,CncCat start end _) = (showCId c, ixs)
   where
-    ixs = makeObj
-      [ ("start", showJSON start)
-      , ("end",   showJSON end)
+    ixs = JSON.makeObj
+      [ ("start", mkJSInt start)
+      , ("end", mkJSInt end)
       ]
 
 frule2json :: Production -> JSValue
 frule2json (PApply fid args) =
-  makeObj
-    [ ("type", showJSON "Apply")
-    , ("fid",  showJSON fid)
-    , ("args", showJSON (map farg2json args))
+  JSON.makeObj
+    [ ("type", mkJSStr "Apply")
+    , ("fid", mkJSInt fid)
+    , ("args", JSArray (map farg2json args))
     ]
 frule2json (PCoerce arg) =
-  makeObj
-    [ ("type", showJSON "Coerce")
-    , ("arg",  showJSON arg)
+  JSON.makeObj
+    [ ("type", mkJSStr "Coerce")
+    , ("arg", mkJSInt arg)
     ]
 
 farg2json :: PArg -> JSValue
 farg2json (PArg hypos fid) =
-  makeObj
-    [ ("type", showJSON "PArg")
-    , ("hypos", JSArray $ map (showJSON . snd) hypos)
-    , ("fid", showJSON fid)
+  JSON.makeObj
+    [ ("type", mkJSStr "PArg")
+    , ("hypos", JSArray $ map (mkJSInt . snd) hypos)
+    , ("fid", mkJSInt fid)
     ]
 
-ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
-ffun2json funid (fun,seqids) =
-  makeObj
-    [ ("name", showJSON fun)
-    , ("lins", showJSON seqids)
+ffun2json :: CncFun -> JSValue
+ffun2json (CncFun f lins) =
+  JSON.makeObj
+    [ ("name", mkJSStr $ showCId f)
+    , ("lins", JSArray (map mkJSInt (Array.elems lins)))
     ]
 
-seq2json :: SeqId -> [Symbol] -> JSValue
-seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
+seq2json :: Array.Array DotPos Symbol -> JSValue
+seq2json seq = JSArray [sym2json s | s <- Array.elems seq]
 
 sym2json :: Symbol -> JSValue
-sym2json (SymCat n l)    = new "SymCat" [showJSON n, showJSON l]
-sym2json (SymLit n l)    = new "SymLit" [showJSON n, showJSON l]
-sym2json (SymVar n l)    = new "SymVar" [showJSON n, showJSON l]
-sym2json (SymKS t)       = new "SymKS"  [showJSON t]
+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"  [showJSON "&+"]
-sym2json SymSOFT_BIND    = new "SymKS"  [showJSON "&+"]
-sym2json SymSOFT_SPACE   = new "SymKS"  [showJSON "&+"]
-sym2json SymCAPIT        = new "SymKS"  [showJSON "&|"]
-sym2json SymALL_CAPIT    = new "SymKS"  [showJSON "&|"]
+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" [showJSON (map sym2json ps), showJSON ts]
+alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
 
 new :: String -> [JSValue] -> JSValue
 new f xs =
-  makeObj
-    [ ("type", showJSON f)
-    , ("args", showJSON 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/PGFtoJava.hs

@@ -1,6 +1,6 @@
 module GF.Compile.PGFtoJava (grammar2java) where
 
-import PGF2
+import PGF
 import Data.Maybe(maybe)
 import Data.List(intercalate)
 import GF.Infra.Option
@@ -24,8 +24,9 @@ javaPreamble name =
  ]
  
 javaMethod gr fun =
-  "  public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++args++"); }"
+  "  public static Expr "++name++"("++arg_decls++") { return new Expr("++show name++args++"); }"
   where
+    name  = showCId fun
     arity = maybe 0 getArrity (functionType gr fun)
     vars  = ['e':show i | i <- [1..arity]]
     

src/compiler/GF/Compile/PGFtoProlog.hs

@@ -0,0 +1,262 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PGFtoProlog
+-- Maintainer  : Peter Ljunglöf
+--
+-- exports a GF grammar into a Prolog module
+-----------------------------------------------------------------------------
+
+module GF.Compile.PGFtoProlog (grammar2prolog) where
+
+import PGF(mkCId,wildCId,showCId)
+import PGF.Internal
+--import PGF.Macros
+
+import GF.Data.Operations
+
+import qualified Data.Array.IArray as Array
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, ord)
+import Data.List (isPrefixOf, mapAccumL)
+
+grammar2prolog :: PGF -> String
+grammar2prolog pgf
+    = ("%% This file was automatically generated by GF" +++++
+       ":- style_check(-singleton)." +++++
+       plFacts wildCId "abstract" 1 "(?AbstractName)"
+                   [[plp name]] ++++
+       plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)" 
+                   [[plp name, plp cncname] | 
+                    cncname <- Map.keys (concretes pgf)] ++++
+       plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags" 
+                   [[plp f, plp v] | 
+                    (f, v) <- Map.assocs (gflags pgf)] ++++
+       plAbstract name (abstract pgf) ++++
+       unlines (map plConcrete (Map.assocs (concretes pgf)))
+      )
+    where name = absname pgf
+
+----------------------------------------------------------------------
+-- abstract syntax
+
+plAbstract :: CId -> Abstr -> String
+plAbstract name abs 
+    = (plHeader "Abstract syntax" ++++
+       plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
+                   [[plp f, plp v] | 
+                    (f, v) <- Map.assocs (aflags abs)] ++++
+       plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
+                   [[plType cat args, plHypos hypos'] |
+                    (cat, (hypos,_,_)) <- Map.assocs (cats abs),
+                    let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
+                        let args = reverse [EFun x | (_,x) <- subst]] ++++
+       plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
+                   [[plp fun, plType cat args, plHypos hypos] |
+                    (fun, (typ, _, _, _)) <- Map.assocs (funs abs),
+                    let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
+       plFacts name "def" 2 "(?Fun, ?Expr)" 
+                   [[plp fun, plp expr] |
+                    (fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
+                    let (_, expr) = alphaConvert emptyEnv eqs]
+      )
+    where plType cat args = plTerm (plp cat) (map plp args)
+          plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
+
+----------------------------------------------------------------------
+-- concrete syntax
+
+plConcrete :: (CId, Concr) -> String
+plConcrete (name, cnc) 
+    = (plHeader ("Concrete syntax: " ++ plp name) ++++
+       plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
+                   [[plp f, plp v] | 
+                    (f, v) <- Map.assocs (cflags cnc)] ++++
+       plFacts name "printname" 2 "(?AbsFun/AbsCat, ?Atom)"
+                   [[plp f, plp n] | 
+                    (f, n) <- Map.assocs (printnames cnc)] ++++
+       plFacts name "lindef" 2 "(?CncCat, ?CncFun)"
+                   [[plCat cat, plFun fun] | 
+                    (cat, funs) <- IntMap.assocs (lindefs cnc),
+                    fun <- funs] ++++
+       plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
+                   [[plCat cat, fun, plTerm "c" (map plCat args)] |
+                    (cat, set) <- IntMap.toList (productions cnc),
+                    (fun, args) <- map plProduction (Set.toList set)] ++++
+       plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
+                   [[plFun fun, plTerm "s" (map plSeq (Array.elems lins)), plp absfun] |
+                    (fun, CncFun absfun lins) <- Array.assocs (cncfuns cnc)] ++++
+       plFacts name "seq" 2 "(?Seq, ?[Term])"
+                   [[plSeq seq, plp (Array.elems symbols)] |
+                    (seq, symbols) <- Array.assocs (sequences cnc)] ++++
+       plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])" 
+                   [[plp cat, plList (map plCat [start..end])] |
+                    (cat, CncCat start end _) <- Map.assocs (cnccats cnc)]
+      )
+    where plProduction (PCoerce arg)       = ("-", [arg])
+          plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
+
+----------------------------------------------------------------------
+-- prolog-printing pgf datatypes
+
+instance PLPrint Type where
+    plp (DTyp hypos cat args) 
+        | null hypos = result
+        | otherwise  = plOper " -> " plHypos result
+        where result = plTerm (plp cat) (map plp args)
+              plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
+
+instance PLPrint Expr where
+    plp (EFun x)    = plp x
+    plp (EAbs _ x e)= plOper "^" (plp x) (plp e)
+    plp (EApp e e') = plOper " * " (plp e) (plp e')
+    plp (ELit lit)  = plp lit
+    plp (EMeta n)   = "Meta_" ++ show n
+
+instance PLPrint Patt where
+    plp (PVar x)    = plp x
+    plp (PApp f ps) = plOper " * " (plp f) (plp ps)
+    plp (PLit lit)  = plp lit
+
+instance PLPrint Equation where
+    plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
+
+instance PLPrint CId where
+    plp cid | isLogicalVariable str || cid == wildCId = plVar str
+            | otherwise = plAtom str
+        where str = showCId cid
+
+instance PLPrint Literal where
+    plp (LStr s) = plp s
+    plp (LInt n) = plp (show n)
+    plp (LFlt f) = plp (show f)
+
+instance PLPrint Symbol where
+    plp (SymCat n l)    = plOper ":" (show n) (show l)
+    plp (SymLit n l)    = plTerm "lit" [show n, show l]
+    plp (SymVar n l)    = plTerm "var" [show n, show l]
+    plp (SymKS t)       = plAtom t
+    plp (SymKP ts alts) = plTerm "pre" [plList (map plp ts), plList (map plAlt alts)]
+        where plAlt (ps,ts) = plOper "/" (plList (map plp ps)) (plList (map plAtom ts))
+
+class PLPrint a where
+    plp :: a -> String
+    plps :: [a] -> String
+    plps = plList . map plp
+
+instance PLPrint Char where
+    plp  c = plAtom [c]
+    plps s = plAtom s
+
+instance PLPrint a => PLPrint [a] where
+    plp = plps
+
+----------------------------------------------------------------------
+-- other prolog-printing functions
+
+plCat :: Int -> String
+plCat n = plAtom ('c' : show n)
+
+plFun :: Int -> String
+plFun n = plAtom ('f' : show n)
+
+plSeq :: Int -> String
+plSeq n = plAtom ('s' : show n)
+
+plHeader :: String -> String
+plHeader hdr = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n%% " ++ hdr ++ "\n"
+
+plFacts :: CId -> String -> Int -> String -> [[String]] -> String
+plFacts mod pred arity comment facts = "%% " ++ pred ++ comment ++++ clauses
+    where clauses = (if facts == [] then ":- dynamic " ++ pred ++ "/" ++ show arity ++ ".\n"
+                     else unlines [mod' ++ plTerm pred args ++ "." | args <- facts])
+          mod' = if mod == wildCId then "" else plp mod ++ ": "
+
+plTerm :: String -> [String] -> String
+plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
+
+plList :: [String] -> String
+plList xs = prBracket (prTList "," xs)
+
+plOper :: String -> String -> String -> String
+plOper op a b = prParenth (a ++ op ++ b)
+
+plVar :: String -> String
+plVar = varPrefix  . concatMap changeNonAlphaNum 
+    where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var
+                              | otherwise = "_" ++ var
+          changeNonAlphaNum c | isAlphaNumUnderscore c = [c]
+                              | otherwise = "_" ++ show (ord c) ++ "_"
+
+plAtom :: String -> String
+plAtom "" = "''"
+plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs 
+                     || c == '\'' && cs /= "" && last cs == '\''   = atom
+                   | otherwise = "'" ++ changeQuote atom ++ "'"
+    where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
+          changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
+          changeQuote (c:cs) = c : changeQuote cs
+          changeQuote "" = ""
+
+isAlphaNumUnderscore :: Char -> Bool
+isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
+
+----------------------------------------------------------------------
+-- prolog variables 
+
+createLogicalVariable :: Int -> CId
+createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n)
+
+isLogicalVariable :: String -> Bool
+isLogicalVariable = isPrefixOf logicalVariablePrefix 
+
+logicalVariablePrefix :: String 
+logicalVariablePrefix = "X"
+
+----------------------------------------------------------------------
+-- alpha convert variables to (unique) logical variables
+-- * this is needed if we want to translate variables to Prolog variables
+-- * used for abstract syntax, not concrete
+-- * not (yet?) used for variables bound in pattern equations
+
+type ConvertEnv = (Int, [(CId,CId)])
+
+emptyEnv :: ConvertEnv
+emptyEnv = (0, [])
+
+class AlphaConvert a where
+    alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a)
+
+instance AlphaConvert a => AlphaConvert [a] where
+    alphaConvert env [] = (env, [])
+    alphaConvert env (a:as) = (env'', a':as')
+        where (env',  a')  = alphaConvert env  a
+              (env'', as') = alphaConvert env' as
+
+instance AlphaConvert Type where
+    alphaConvert env@(_,subst) (DTyp hypos cat args) 
+        = ((ctr,subst), DTyp hypos' cat args')
+        where (env',   hypos') = mapAccumL alphaConvertHypo env hypos
+              ((ctr,_), args') = alphaConvert env' args
+
+alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ'))
+    where ((ctr,subst), typ') = alphaConvert env typ
+          x' = createLogicalVariable ctr
+
+instance AlphaConvert Expr where
+    alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e')
+        where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e
+              x' = createLogicalVariable ctr
+    alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
+        where (env',  e1') = alphaConvert env  e1
+              (env'', e2') = alphaConvert env' e2
+    alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
+    alphaConvert env expr = (env, expr)
+
+-- pattern variables are not alpha converted
+-- (but they probably should be...)
+instance AlphaConvert Equation where
+    alphaConvert env@(_,subst) (Equ patterns result)
+        = ((ctr,subst), Equ patterns result')
+        where ((ctr,_), result') = alphaConvert env result

src/compiler/GF/Compile/PGFtoPython.hs

@@ -0,0 +1,122 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PGFtoPython
+-- Maintainer  : Peter Ljunglöf
+--
+-- exports a GF grammar into a Python module
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+module GF.Compile.PGFtoPython (pgf2python) where
+
+import PGF(showCId)
+import PGF.Internal as M
+
+import GF.Data.Operations
+
+import qualified Data.Array.IArray as Array
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+--import Data.List (intersperse)
+
+pgf2python :: PGF -> String
+pgf2python pgf = ("# -*- coding: utf-8 -*-" ++++
+                  "# This file was automatically generated by GF" +++++
+                  showCId name +++ "=" +++ 
+                  pyDict 1 pyStr id [
+                              ("flags", pyDict 2 pyCId pyLiteral (Map.assocs (gflags pgf))),
+                              ("abstract", pyDict 2 pyStr id [
+                                              ("name", pyCId name), 
+                                              ("start", pyCId start), 
+                                              ("flags", pyDict 3 pyCId pyLiteral (Map.assocs (aflags abs))),
+                                              ("funs", pyDict 3 pyCId pyAbsdef (Map.assocs (funs abs)))
+                                             ]),
+                              ("concretes", pyDict 2 pyCId pyConcrete (Map.assocs cncs))
+                             ] ++ "\n")
+    where
+      name  = absname pgf
+      start = M.lookStartCat pgf
+      abs = abstract pgf
+      cncs = concretes pgf
+
+pyAbsdef :: (Type, Int, Maybe ([Equation], [[M.Instr]]), Double) -> String
+pyAbsdef (typ, _, _, _) = pyTuple 0 id [pyCId cat, pyList 0 pyCId args]
+    where (args, cat) = M.catSkeleton typ 
+
+pyLiteral :: Literal -> String
+pyLiteral (LStr s) = pyStr s
+pyLiteral (LInt n) = show n
+pyLiteral (LFlt d) = show d
+
+pyConcrete :: Concr -> String
+pyConcrete cnc = pyDict 3 pyStr id [
+                  ("flags", pyDict 0 pyCId pyLiteral (Map.assocs (cflags cnc))),
+                  ("printnames", pyDict 4 pyCId pyStr (Map.assocs (printnames cnc))),
+                  ("lindefs", pyDict 4 pyCat (pyList 0 pyFun) (IntMap.assocs (lindefs cnc))),
+                  ("productions", pyDict 4 pyCat pyProds (IntMap.assocs (productions cnc))),
+                  ("cncfuns", pyDict 4 pyFun pyCncFun (Array.assocs (cncfuns cnc))),
+                  ("sequences",  pyDict 4 pySeq pySymbols (Array.assocs (sequences cnc))),
+                  ("cnccats", pyDict 4 pyCId pyCncCat (Map.assocs (cnccats cnc))),
+                  ("size",  show (totalCats cnc))
+                 ]
+    where pyProds prods = pyList 5 pyProduction (Set.toList prods)
+          pyCncCat (CncCat start end _) = pyList 0 pyCat [start..end]
+          pyCncFun (CncFun f lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyCId f]
+          pySymbols syms = pyList 0 pySymbol (Array.elems syms)
+
+pyProduction :: Production -> String
+pyProduction (PCoerce arg)       = pyTuple 0 id [pyStr "", pyList 0 pyCat [arg]]
+pyProduction (PApply funid args) = pyTuple 0 id [pyFun funid, pyList 0 pyPArg args]
+    where pyPArg (PArg [] fid) = pyCat fid
+          pyPArg (PArg hypos fid) = pyTuple 0 pyCat (fid : map snd hypos)
+
+pySymbol :: Symbol -> String
+pySymbol (SymCat n l)    = pyTuple 0 show [n, l]
+pySymbol (SymLit n l)    = pyDict 0 pyStr id [("lit", pyTuple 0 show [n, l])]
+pySymbol (SymVar n l)    = pyDict 0 pyStr id [("var", pyTuple 0 show [n, l])]
+pySymbol (SymKS t)       = pyStr t
+pySymbol (SymKP ts alts) = pyDict 0 pyStr id [("pre", pyList 0 pySymbol ts), ("alts", pyList 0 alt2py alts)]
+    where alt2py (ps,ts) = pyTuple 0 (pyList 0 pyStr) [map pySymbol ps, ts]
+pySymbol SymBIND         = pyStr "&+"
+pySymbol SymSOFT_BIND    = pyStr "&+"
+pySymbol SymSOFT_SPACE   = pyStr "&+"
+pySymbol SymCAPIT        = pyStr "&|"
+pySymbol SymALL_CAPIT    = pyStr "&|"
+pySymbol SymNE           = pyDict 0 pyStr id [("nonExist", pyTuple 0 id [])]
+
+----------------------------------------------------------------------
+-- python helpers 
+
+pyDict :: Int -> (k -> String) -> (v -> String) -> [(k, v)] -> String
+pyDict n pk pv [] = "{}"
+pyDict n pk pv kvlist = prCurly (pyIndent n ++ prTList ("," ++ pyIndent n) (map pyKV kvlist) ++ pyIndent n)
+    where pyKV (k, v) = pk k ++ ":" ++ pv v
+
+pyList :: Int -> (v -> String) -> [v] -> String
+pyList n pv [] = "[]"
+pyList n pv xs = prBracket (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
+
+pyTuple :: Int -> (v -> String) -> [v] -> String
+pyTuple n pv [] = "()"
+pyTuple n pv [x] = prParenth (pyIndent n ++ pv x ++ "," ++ pyIndent n)
+pyTuple n pv xs = prParenth (pyIndent n ++ prTList ("," ++ pyIndent n) (map pv xs) ++ pyIndent n)
+
+pyCat :: Int -> String
+pyCat n = pyStr ('C' : show n)
+
+pyFun :: Int -> String
+pyFun n = pyStr ('F' : show n)
+
+pySeq :: Int -> String
+pySeq n = pyStr ('S' : show n)
+
+pyStr :: String -> String
+pyStr s = 'u' : prQuotedString s
+
+pyCId :: CId -> String
+pyCId = pyStr . showCId
+
+pyIndent :: Int -> String
+pyIndent n | n > 0 = "\n" ++ replicate n ' '
+           | otherwise = ""

src/compiler/GF/Compile/Rename.hs

@@ -110,7 +110,7 @@ renameIdentTerm' env@(act,imps) t0 =
 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
+  ResValue _  -> maybe Con (curry QC) mq
   ResParam _ _  -> maybe Con (curry QC) mq
   AnyInd True m -> maybe Con (const (curry QC m)) mq
   AnyInd False m -> maybe Cn (const (curry Q m)) mq
@@ -148,9 +148,9 @@ renameInfo cwd status (m,mi) i info =
     ResParam (Just pp) m -> do
       pp' <- renLoc (mapM (renParam status)) pp
       return (ResParam (Just pp') m)
-    ResValue ty offset -> do
-      t <- renLoc (renameTerm status []) ty
-      return (ResValue ty offset)
+    ResValue t -> do
+      t <- renLoc (renameTerm status []) t
+      return (ResValue t)
     CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
     CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty)         (renTerm mtr) (renTerm mpr) (return mpmcfg)
     _ -> return info
@@ -178,9 +178,9 @@ renameInfo cwd status (m,mi) i info =
         return (ps',t')
 
     renParam :: Status -> Param -> Check Param
-    renParam env (c,co,i) = do
+    renParam env (c,co) = do
       co' <- renameContext env co
-      return (c,co',i)
+      return (c,co')
 
 renameTerm :: Status -> [Ident] -> Term -> Check Term
 renameTerm env vars = ren vars where
@@ -236,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/Tags.hs

@@ -31,7 +31,7 @@ getLocalTags x (m,mi) =
     getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
                                                   maybe (list (loc "def"))   mb_eqs  
     getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
-    getLocations (ResValue mb_type _)           = ltype "param-value"          mb_type
+    getLocations (ResValue mb_type)             = ltype "param-value"          mb_type
     getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++
                                                   maybe (loc "oper-def")     mb_def
     getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 

src/compiler/GF/Compile/ToAPI.hs

@@ -2,7 +2,8 @@ module GF.Compile.ToAPI
  (stringToAPI,exprToAPI)
   where
 
-import PGF2
+import PGF.Internal
+import PGF(showCId)
 import Data.Maybe
 --import System.IO
 --import Control.Monad
@@ -46,12 +47,12 @@ exprToFunc :: Expr -> APIfunc
 exprToFunc expr = 
    case unApp expr of
       Just (cid,l) -> 
-         case Map.lookup cid syntaxFuncs of 
+         case Map.lookup (showCId cid) syntaxFuncs of 
             Just sig -> mkAPI True (fst sig,expr)
             _        -> case l of 
-                          [] -> BasicFunc cid 
+                          [] -> BasicFunc (showCId cid) 
                           _  -> let es = map exprToFunc l 
-                                   in  AppFunc cid es
+                                   in  AppFunc (showCId cid) es
       _ -> BasicFunc (showExpr [] expr)
 
         
@@ -68,8 +69,8 @@ mkAPI opt (ty,expr) =
   where
      rephraseSentence ty expr = 
        case unApp expr of 
-         Just (cid,es) -> if isPrefixOf "Use" cid then 
-                                                             let newCat = drop 3 cid
+         Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then 
+                                                             let newCat = drop 3 (showCId cid)
                                                                  afClause = mkAPI True (newCat, es !! 2)
                                                                  afPol = mkAPI True ("Pol",es !! 1)                                         
                                                                  lTense = mkAPI True ("Temp", head es)                                        
@@ -97,9 +98,9 @@ mkAPI opt (ty,expr) =
 computeAPI :: (String,Expr) ->  APIfunc
 computeAPI (ty,expr) =
    case (unApp expr) of 
-     Just (cid,[]) ->  getSimpCat cid ty
+     Just (cid,[]) ->  getSimpCat (showCId cid) ty
      Just (cid,es) -> 
-        let p = specFunction cid es  
+        let p = specFunction (showCId cid) es  
           in if isJust p then fromJust p
               else case Map.lookup (show cid) syntaxFuncs of
                     Nothing -> exprToFunc expr    
@@ -146,23 +147,23 @@ optimize expr = optimizeNP expr
 optimizeNP expr = 
    case unApp expr of
      Just (cid,es) -> 
-         if cid == "MassNP" then let afs = nounAsCN (head es)
-                                 in AppFunc "mkNP" [afs]
-           else if cid == "DetCN" then let quants = quantAsDet (head es)
-                                           ns     = nounAsCN (head $ tail es)
-                                       in AppFunc "mkNP" (quants ++ [ns])
+         if showCId cid == "MassNP" then let afs = nounAsCN (head es)
+                                           in AppFunc "mkNP" [afs]
+           else if showCId cid == "DetCN" then let quants = quantAsDet (head es)
+                                                   ns     = nounAsCN (head $ tail es)
+                                                  in AppFunc "mkNP" (quants ++ [ns])
                  else mkAPI False ("NP",expr)
      _             -> error $ "incorrect expression " ++ (showExpr [] expr)
     where 
      nounAsCN expr = 
       case unApp expr of 
-       Just (cid,es) -> if cid == "UseN" then (mkAPI False) ("N",head es)
+       Just (cid,es) -> if showCId cid == "UseN" then (mkAPI False) ("N",head es)
            else (mkAPI False) ("CN",expr)
        _ -> error $ "incorrect expression "++ (showExpr [] expr)
 
      quantAsDet expr =
        case unApp expr of
-        Just (cid,es) -> if cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
+        Just (cid,es) -> if showCId cid == "DetQuant" then map (mkAPI False) [("Quant", head es),("Num",head $ tail es)]
                            else [mkAPI False ("Det",expr)]
                                   
         _             -> error $ "incorrect expression "++ (showExpr [] expr)

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/Primitives.hs

@@ -8,7 +8,7 @@ typPredefined :: Ident -> Maybe Type
 typPredefined f = case Map.lookup f primitives of
                     Just (ResOper (Just (L _ ty)) _) -> Just ty
                     Just (ResParam _ _)              -> Just typePType
-                    Just (ResValue (L _ ty) _)       -> Just ty
+                    Just (ResValue (L _ ty))         -> Just ty
                     _                                -> Nothing
 
 primitives = Map.fromList
@@ -16,9 +16,9 @@ primitives = Map.fromList
   , (cInt      , ResOper (Just (noLoc typePType)) Nothing)
   , (cFloat    , ResOper (Just (noLoc typePType)) Nothing)
   , (cInts     , fun [typeInt] typePType)
-  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[],0),(cPFalse,[],1)])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
-  , (cPTrue    , ResValue (noLoc typePBool) 0)
-  , (cPFalse   , ResValue (noLoc typePBool) 1)
+  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
+  , (cPTrue    , ResValue (noLoc typePBool))
+  , (cPFalse   , ResValue (noLoc typePBool))
   , (cError    , fun [typeStr] typeError)  -- non-can. of empty set
   , (cLength   , fun [typeTok] typeInt)
   , (cDrop     , fun [typeInt,typeTok] typeTok)

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE PatternGuards #-}
 module GF.Compile.TypeCheck.RConcrete( checkLType, inferLType, computeLType, ppType ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Infra.CheckM
 import GF.Data.Operations
@@ -126,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) 
-           _ -> checkError ("A function type is expected for" <+> ppTerm Unqualified 0 f <+> "instead of type" <+> ppType fty)
+             return (App f' a',ty)
+           _ ->
+             let term = ppTerm Unqualified 0 f
+                 funName = pp . head . words .render $ term
+              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
+                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")
 
    S f x -> do
      (f', fty) <- inferLType gr g f
@@ -219,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
 
@@ -326,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
@@ -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 $$
-                          "expected:" <+> ppTerm Qualified 0 t $$ -- ppqType t u $$
-                          "inferred:" <+> ppTerm Qualified 0 u -- ppqType u t
+    False ->
+      let inferredType = ppTerm Qualified 0 u
+          expectedType = ppTerm Qualified 0 t
+          term = ppTerm Unqualified 0 trm
+          funName = pp . head . words .render $ term
+          helpfulMsg =
+            case (arrows inferredType, arrows expectedType) of
+              (0,0) -> pp "" -- None of the types is a function
+              _ -> "\n   **" <+> 
+                  if expectedType `isLessApplied` inferredType
+                    then "Maybe you gave too few arguments to" <+> funName
+                    else pp "Double-check that type signature and number of arguments match."
+      in checkError $ s <+> "type of" <+> term $$
+                            "expected:" <+> expectedType $$ -- ppqType t u $$
+                            "inferred:" <+> inferredType $$ -- ppqType u t
+                            helpfulMsg
+  where
+    -- count the number of arrows in the prettyprinted term
+    arrows :: Doc -> Int
+    arrows = length . filter (=="->") . words . render
+
+    -- If prettyprinted type t has fewer arrows then prettyprinted type u,
+    -- then t is "less applied", and we can print out more helpful error msg.
+    isLessApplied :: Doc -> Doc -> Bool
+    isLessApplied t u = arrows t < arrows u
 
 checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
 checkIfEqLType gr g t u trm = do

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 (Map.Map Ident Info)
+buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info)
 buildAnyTree m = go Map.empty
   where
     go map []         = return map
@@ -109,8 +110,9 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
     -- add the instance opens to an incomplete module "with" instances
     Just (ext,incl,ops) -> do
       let (infs,insts) = unzip ops
-      let stat' = ifNull MSComplete (const MSIncomplete)
-                    [i | i <- is, notElem i infs]
+      let stat' = if all (flip elem infs) is
+                    then MSComplete
+                    else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete) 
              (checkError ("module" <+> i <+> "remains incomplete"))
       ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
@@ -166,7 +168,7 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
     indirInfo :: ModuleName -> Info -> Info
     indirInfo n info = AnyInd b n' where 
       (b,n') = case info of
-        ResValue _ _ -> (True,n)
+        ResValue _ -> (True,n)
         ResParam _ _ -> (True,n)
         AbsFun _ _ Nothing _ -> (True,n) 
         AnyInd b k -> (b,k)
@@ -177,7 +179,7 @@ globalizeLoc fpath i =
     AbsCat mc             -> AbsCat (fmap gl mc)
     AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
     ResParam mt mv        -> ResParam (fmap gl mt) mv
-    ResValue t offset     -> ResValue (gl t) offset
+    ResValue t            -> ResValue (gl t)
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
     ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
     CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
@@ -199,9 +201,9 @@ unifyAnyInfo m i j = case (i,j) of
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
-  (ResValue (L l1 t1) i1, ResValue (L l2 t2) i2) 
-      | t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
-      | otherwise          -> fail ""
+  (ResValue (L l1 t1), ResValue (L l2 t2)) 
+      | t1==t2    -> return (ResValue (L l1 t1))
+      | otherwise -> fail ""
   (_, ResOverload ms t) | elem m ms ->
     return $ ResOverload ms t
   (ResOper mt1 m1, ResOper mt2 m2) -> 

src/compiler/GF/CompileInParallel.hs

@@ -1,6 +1,6 @@
 -- | Parallel grammar compilation
 module GF.CompileInParallel(parallelBatchCompile) where
-import Prelude hiding (catch)
+import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import Control.Monad(join,ap,when,unless)
 import Control.Applicative
 import GF.Infra.Concurrency
@@ -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.
@@ -34,8 +36,11 @@ import qualified Data.ByteString.Lazy as BS
 parallelBatchCompile jobs opts rootfiles0 =
   do setJobs jobs
      rootfiles <- mapM canonical rootfiles0
-     lib_dir  <- canonical =<< getLibraryDirectory opts
-     filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
+     lib_dirs1 <- getLibraryDirectory opts
+     lib_dirs2 <- mapM canonical lib_dirs1
+     let lib_dir = head lib_dirs2
+     when (length lib_dirs2 >1) $ ePutStrLn ("GF_LIB_PATH defines more than one directory; using the first, " ++ show lib_dir)
+     filepaths <- mapM (getPathFromFile [lib_dir] opts) rootfiles
      let groups = groupFiles lib_dir filepaths
          n = length groups
      when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"
@@ -80,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)
@@ -238,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,()))
@@ -253,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,8 +1,11 @@
-module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writePGF, writeLPGF, writeOutputs) where
 
-import PGF2
-import PGF2.Internal(unionPGF,writePGF,writeConcr)
-import GF.Compile as S(batchCompile,link,srcAbsName)
+import PGF
+import PGF.Internal(concretes,optimizePGF,unionPGF)
+import PGF.Internal(putSplitAbs,encodeFile,runPut)
+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)
@@ -10,7 +13,8 @@ import GF.Compile.GrammarToCanonical--(concretes2canonical)
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
-import GF.Grammar.CFG
+import GF.Grammar.CFG hiding (Grammar)
+import GF.Grammar.Grammar (Grammar, ModuleName)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
@@ -22,10 +26,11 @@ import GF.Text.Pretty(render,render80)
 import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Time(UTCTime)
 import qualified Data.ByteString.Lazy as BSL
 import GF.Grammar.CanonicalJSON (encodeJSON)
 import System.FilePath
-import Control.Monad(when,unless,forM_)
+import Control.Monad(when,unless,forM,void)
 
 -- | Compile the given GF grammar files. The result is a number of @.gfo@ files
 -- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
@@ -46,7 +51,7 @@ mainGFC opts fs = do
    extensionIs ext = (== ext) .  takeExtension
 
 compileSourceFiles :: Options -> [FilePath] -> IOE ()
-compileSourceFiles opts fs = 
+compileSourceFiles opts fs =
     do output <- batchCompile opts fs
        exportCanonical output
        unless (flag optStopAfterPhase opts == Compile) $
@@ -91,7 +96,11 @@ compileSourceFiles opts fs =
 -- in the 'Options') from the output of 'parallelBatchCompile'.
 -- 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 'writeGrammar' and 'writeOutputs'.
+-- 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")
@@ -101,8 +110,10 @@ 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 (\one two -> fromMaybe two (unionPGF one two)) pgfs
-                 writeGrammar opts pgf
+                 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
 
 compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -112,11 +123,12 @@ compileCFFiles opts fs = do
   startCat <- case rules of
                 (Rule cat _ _ : _) -> return cat
                 _                  -> fail "empty CFG"
-  probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
-  let pgf = cf2pgf opts (last fs) (mkCFG startCat Set.empty rules) probs
+  let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
   unless (flag optStopAfterPhase opts == Compile) $
-     do writeGrammar opts pgf
-        writeOutputs opts pgf
+     do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
+        let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
+        writePGF opts pgf'
+        writeOutputs opts pgf'
 
 unionPGFFiles :: Options -> [FilePath] -> IOE ()
 unionPGFFiles opts fs =
@@ -134,11 +146,14 @@ unionPGFFiles opts fs =
 
     doIt =
       do pgfs <- mapM readPGFVerbose fs
-         let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
-         let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
+         let pgf0 = foldl1 unionPGF pgfs
+             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 writeGrammar opts pgf
+           else void $ writePGF opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -148,37 +163,51 @@ 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.
-writeGrammar :: Options -> PGF -> IOE ()
-writeGrammar opts pgf =
-  if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
+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 (writePGF outfile pgf)
+          writing opts outfile $ encodeFile outfile pgf
+          return [outfile]
 
     writeSplitPGF =
       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-         writing opts outfile $ writePGF outfile pgf
-         forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do
-           let outfile = outputPath opts (concrname <.> "pgf_c")
-           writing opts outfile (writeConcr outfile concr)
+         writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
+                                --encodeFile_ outfile (putSplitAbs pgf)
+         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 ()
-writeOutput opts file str = writing opts path $ writeUTF8File path str
-  where path = outputPath opts file
+writeLPGF :: Options -> LPGF -> IOE FilePath
+writeLPGF opts lpgf = do
+  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
 
 grammarName :: Options -> PGF -> String
-grammarName opts pgf = grammarName' opts (abstractName pgf)
+grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
 grammarName' opts abs = fromMaybe abs (flag optName opts)
 
 outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)

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

src/compiler/GF/Data/Operations.hs

@@ -26,8 +26,8 @@ module GF.Data.Operations (
 		   -- ** Checking
 		   checkUnique, unifyMaybeBy, unifyMaybe,
 
-                   -- ** Monadic operations on lists and pairs
-		   mapPairListM, mapPairsM, pairM,
+           -- ** Monadic operations on lists and pairs
+		   mapPairsM, pairM,
  
 		   -- ** Printing
 		   indent, (+++), (++-), (++++), (+++-), (+++++),
@@ -39,8 +39,7 @@ module GF.Data.Operations (
 		   topoTest, topoTest2,
 
 		   -- ** Misc
-		   ifNull,
-		   combinations, done, readIntArg, --singleton,
+		   readIntArg,
 		   iterFix,  chunks,
                 
 		  ) where
@@ -54,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
@@ -70,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))
@@ -78,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
 
@@ -95,10 +89,10 @@ 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 ""
@@ -193,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'
@@ -247,10 +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
 
--- | @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

src/compiler/GF/Grammar/Analyse.hs

@@ -29,7 +29,7 @@ stripInfo i = case i of
   AbsCat _ -> i
   AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
   ResParam mp mt -> ResParam mp Nothing
-  ResValue _ lt -> i ----
+  ResValue lt -> i ----
   ResOper mt md -> ResOper mt Nothing
   ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
   CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
@@ -107,8 +107,8 @@ sizeInfo i = case i of
   AbsFun mt mi me mb -> 1 + msize mt + 
     sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
   ResParam mp mt -> 
-    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co,_) <- ps]
-  ResValue _ lt -> 0
+    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
+  ResValue lt -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
   CncCat mty _ _ _ _ -> 1 + msize mty   -- ignoring lindef, linref and printname

src/compiler/GF/Grammar/BNFC.hs

@@ -15,6 +15,7 @@
 module GF.Grammar.BNFC(BNFCRule(..), BNFCSymbol, Symbol(..), CFTerm(..), bnfc2cf) where
 
 import GF.Grammar.CFG
+import PGF (Token, mkCId)
 import Data.List (partition)
 
 type IsList = Bool
@@ -63,12 +64,12 @@ transformRules sepMap (BNFCCoercions c num) = rules ++ [lastRule]
                 lastRule = Rule (c',[0]) ss rn
                   where c' = c ++ show num
                         ss = [Terminal "(", NonTerminal (c,[0]), Terminal ")"]
-                        rn = CFObj ("coercion_" ++ c) []
+                        rn = CFObj (mkCId $ "coercion_" ++ c) []
 
 fRules c n = Rule (c',[0]) ss rn
    where c' = if n == 0 then c else c ++ show n
          ss = [NonTerminal (c ++ show (n+1),[0])]
-         rn = CFObj ("coercion_" ++ c') []
+         rn = CFObj (mkCId $ "coercion_" ++ c') []
 
 transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol)
 transformSymb sepMap s = case s of
@@ -93,7 +94,7 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
                        then [NonTerminal (c,[0]) | ne]
                        else [NonTerminal (c,[0]) | ne] ++
                             [Terminal symb | symb /= "" && ne]
-                rn   = CFObj ("Base" ++ c) []
+                rn   = CFObj (mkCId $ "Base" ++ c) []
         ruleCons
           | isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn
                                             ,Rule ("List" ++ c,[1]) smbs1 rn]
@@ -106,4 +107,4 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
                 smbs = [NonTerminal (c,[0])] ++
                        [Terminal symb | symb /= ""] ++
                        [NonTerminal ("List" ++ c,[0])]
-                rn   = CFObj ("Cons" ++ c) []
+                rn   = CFObj (mkCId $ "Cons" ++ c) []

src/compiler/GF/Grammar/Binary.hs

@@ -10,9 +10,9 @@
 module GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader,decodeModule,encodeModule) where
 
 import Prelude hiding (catch)
-import Control.Monad
 import Control.Exception(catch,ErrorCall(..),throwIO)
-import Data.Binary
+
+import PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
 import qualified Data.Map as Map(empty)
 import qualified Data.ByteString.Char8 as BS
 
@@ -22,10 +22,11 @@ import GF.Infra.Option
 import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
-import PGF2.Internal(Literal(..),Symbol(..))
+import PGF() -- Binary instances
+import PGF.Internal(Literal(..))
 
 -- Please change this every time when the GFO format is changed
-gfoVersion = "GF05"
+gfoVersion = "GF04"
 
 instance Binary Ident where
   put id = put (ident2utf8 id)
@@ -119,7 +120,7 @@ instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
   put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
   put (ResParam x y)   = putWord8 2 >> put (x,y)
-  put (ResValue x y)   = putWord8 3 >> put (x,y)
+  put (ResValue x)     = putWord8 3 >> put x
   put (ResOper x y)    = putWord8 4 >> put (x,y)
   put (ResOverload x y)= putWord8 5 >> put (x,y)
   put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
@@ -130,7 +131,7 @@ instance Binary Info where
              0 -> get >>= \x         -> return (AbsCat x)
              1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
              2 -> get >>= \(x,y)     -> return (ResParam x y)
-             3 -> get >>= \(x,y)     -> return (ResValue x y)
+             3 -> get >>= \x         -> return (ResValue x)
              4 -> get >>= \(x,y)     -> return (ResOper x y)
              5 -> get >>= \(x,y)     -> return (ResOverload x y)
              6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)
@@ -297,53 +298,6 @@ instance Binary Label where
              1 -> fmap LVar   get
              _ -> decodingError
 
-instance Binary BindType where
-  put Explicit = putWord8 0
-  put Implicit = putWord8 1
-  get = do tag <- getWord8
-           case tag of
-             0 -> return Explicit
-             1 -> return Implicit
-             _ -> decodingError
-
-instance Binary Literal where
-  put (LStr s) = putWord8 0 >> put s
-  put (LInt i) = putWord8 1 >> put i
-  put (LFlt d) = putWord8 2 >> put d
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM  LStr get
-             1 -> liftM  LInt get
-             2 -> liftM  LFlt get
-             _ -> decodingError
-
-instance Binary Symbol where
-  put (SymCat n l)       = putWord8 0 >> put (n,l)
-  put (SymLit n l)       = putWord8 1 >> put (n,l)
-  put (SymVar n l)       = putWord8 2 >> put (n,l)
-  put (SymKS ts)         = putWord8 3 >> put ts
-  put (SymKP d vs)       = putWord8 4 >> put (d,vs)
-  put SymBIND            = putWord8 5
-  put SymSOFT_BIND       = putWord8 6
-  put SymNE              = putWord8 7
-  put SymSOFT_SPACE      = putWord8 8
-  put SymCAPIT           = putWord8 9
-  put SymALL_CAPIT       = putWord8 10
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM2 SymCat get get
-             1 -> liftM2 SymLit get get
-             2 -> liftM2 SymVar get get
-             3 -> liftM  SymKS  get
-             4 -> liftM2 (\d vs -> SymKP d vs) get get
-             5 -> return SymBIND
-             6 -> return SymSOFT_BIND
-             7 -> return SymNE
-             8 -> return SymSOFT_SPACE
-             9 -> return SymCAPIT
-             10-> return SymALL_CAPIT
-             _ -> decodingError
-
 --putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
 --getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
 --putGFOVersion = put gfoVersion

src/compiler/GF/Grammar/CFG.hs

@@ -4,11 +4,10 @@
 --
 -- Context-free grammar representation and manipulation.
 ----------------------------------------------------------------------
-module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
+module GF.Grammar.CFG where
 
 import GF.Data.Utilities
-import PGF2(Fun,Cat)
-import PGF2.Internal(Token)
+import PGF
 import GF.Data.Relation
 
 import Data.Map (Map)
@@ -21,6 +20,8 @@ import qualified Data.Set as Set
 -- * Types
 --
 
+type Cat = String
+
 data Symbol c t = NonTerminal c | Terminal t
   deriving (Eq, Ord, Show)
 
@@ -38,12 +39,12 @@ data Grammar c t = Grammar {
   deriving (Eq, Ord, Show)
 
 data CFTerm
-    = CFObj Fun [CFTerm] -- ^ an abstract syntax function with arguments
+    = CFObj CId [CFTerm] -- ^ an abstract syntax function with arguments
     | CFAbs Int CFTerm -- ^ A lambda abstraction. The Int is the variable id.
     | CFApp CFTerm CFTerm -- ^ Application
     | CFRes Int -- ^ The result of the n:th (0-based) non-terminal
     | CFVar Int -- ^ A lambda-bound variable
-    | CFMeta Fun -- ^ A metavariable
+    | CFMeta CId -- ^ A metavariable
   deriving (Eq, Ord, Show)
 
 type CFSymbol = Symbol  Cat Token
@@ -231,7 +232,7 @@ uniqueFuns = snd . mapAccumL uniqueFun Set.empty
     uniqueFun funs (Rule cat items (CFObj fun args)) = (Set.insert fun' funs,Rule cat items (CFObj fun' args))
       where
         fun' = head [fun'|suffix<-"":map show ([2..]::[Int]),
-                          let fun'=fun++suffix,
+                          let fun'=mkCId (showCId fun++suffix),
                           not (fun' `Set.member` funs)]
 
 -- | Gets all rules in a CFG.
@@ -309,12 +310,12 @@ prProductions prods =
 prCFTerm :: CFTerm -> String
 prCFTerm = pr 0
   where
-    pr p (CFObj f args) = paren p (f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
+    pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
     pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t)
     pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")")
     pr _ (CFRes i) = "$" ++ show i
     pr _ (CFVar i) = "x" ++ show i
-    pr _ (CFMeta c) = "?" ++ c
+    pr _ (CFMeta c) = "?" ++ showCId c
     paren 0 x = x
     paren 1 x = "(" ++ x ++ ")"
 
@@ -322,12 +323,12 @@ prCFTerm = pr 0
 -- * CFRule Utilities
 --
 
-ruleFun :: Rule c t -> Fun
+ruleFun :: Rule c t -> CId
 ruleFun (Rule _ _ t) = f t
   where f (CFObj n _) = n
         f (CFApp _ x) = f x
         f (CFAbs _ x) = f x
-        f _ = ""
+        f _ = mkCId ""
 
 -- | Check if any of the categories used on the right-hand side
 --   are in the given list of categories.
@@ -335,7 +336,7 @@ anyUsedBy :: Eq c => [c] -> Rule c t -> Bool
 anyUsedBy cs (Rule _ ss _) = any (`elem` cs) (filterCats ss)
 
 mkCFTerm :: String -> CFTerm
-mkCFTerm n = CFObj n []
+mkCFTerm n = CFObj (mkCId n) []
 
 ruleIsNonRecursive :: Ord c => Set c -> Rule c t -> Bool
 ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs

src/compiler/GF/Grammar/Canonical.hs

@@ -30,7 +30,7 @@ data TypeApp  = TypeApp CatId [Type]        deriving Show
 data TypeBinding = TypeBinding VarId Type   deriving Show
 
 --------------------------------------------------------------------------------
--- ** Concreate syntax
+-- ** Concrete syntax
 
 -- | Concrete Syntax
 data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
@@ -44,12 +44,12 @@ data LincatDef = LincatDef CatId LinType  deriving Show
 data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
 
 -- | Linearization type, RHS of @lincat@
-data LinType = FloatType 
-             | IntType 
+data LinType = FloatType
+             | IntType
              | ParamType ParamType
              | RecordType [RecordRowType]
-             | StrType 
-             | TableType LinType LinType 
+             | StrType
+             | TableType LinType LinType
              | TupleType [LinType]
               deriving (Eq,Ord,Show)
 
@@ -59,7 +59,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 data LinValue = ConcatValue LinValue LinValue
               | LiteralValue LinLiteral
               | ErrorValue String
-              | ParamConstant ParamValue 
+              | ParamConstant ParamValue
               | PredefValue PredefId
               | RecordValue [RecordRowValue]
               | TableValue LinType [TableRowValue]
@@ -73,9 +73,9 @@ data LinValue = ConcatValue LinValue LinValue
               | CommentedValue String LinValue
               deriving (Eq,Ord,Show)
 
-data LinLiteral = FloatConstant Float 
-                | IntConstant Int 
-                | StrConstant String 
+data LinLiteral = FloatConstant Float
+                | IntConstant Int
+                | StrConstant String
                 deriving (Eq,Ord,Show)
 
 data LinPattern = ParamPattern ParamPattern
@@ -102,11 +102,11 @@ data TableRow  rhs = TableRow  LinPattern rhs
 
 -- *** Identifiers in Concrete Syntax
 
-newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
-newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
-data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
+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 
+-- | Name of param type or param value
 newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
@@ -115,9 +115,9 @@ newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 newtype ModId = ModId Id  deriving (Eq,Ord,Show)
 
 newtype CatId = CatId Id  deriving (Eq,Ord,Show)
-newtype FunId = FunId Id  deriving (Eq,Show)
+newtype FunId = FunId Id  deriving (Eq,Ord,Show)
 
-data VarId = Anonymous | VarId Id  deriving Show
+data VarId = Anonymous | VarId Id  deriving (Eq,Show)
 
 newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
 type FlagName = Id
@@ -249,7 +249,7 @@ instance PPA LinLiteral where
             FloatConstant f -> pp f
             IntConstant n -> pp n
             StrConstant s -> doubleQuotes s -- hmm
-  
+
 instance RhsSeparator LinValue where rhsSep _ = pp "="
 
 instance Pretty LinPattern where
@@ -264,7 +264,7 @@ instance PPA LinPattern where
       ParamPattern pv -> ppA pv
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"                
+      WildPattern     -> pp "_"
       _ -> parens p
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -6,6 +6,7 @@ import Text.JSON
 import Control.Applicative ((<|>))
 import Data.Ratio (denominator, numerator)
 import GF.Grammar.Canonical
+import Control.Monad (guard)
 
 
 encodeJSON :: FilePath -> Grammar -> IO ()
@@ -126,10 +127,10 @@ instance JSON LinType where
   -- records are encoded as records:
   showJSON (RecordType rows) = showJSON rows
 
-  readJSON o = do "Str"   <- readJSON o; return StrType
-    <|>        do "Float" <- readJSON o; return FloatType
-    <|>        do "Int"   <- readJSON o; return IntType
-    <|>        do  ptype  <- readJSON o; return (ParamType ptype)
+  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
@@ -186,7 +187,7 @@ instance JSON LinPattern where
   -- and records as records:
   showJSON (RecordPattern r) = showJSON r
 
-  readJSON o = do "_" <- readJSON o; return WildPattern
+  readJSON o = do  p  <- parseString "_" o; return WildPattern
     <|>        do  p  <- readJSON o; return (ParamPattern (Param p []))
     <|>        ParamPattern  <$> readJSON o
     <|>        RecordPattern <$> readJSON o
@@ -237,7 +238,7 @@ instance JSON VarId where
   showJSON Anonymous = showJSON "_"
   showJSON (VarId x) = showJSON x
 
-  readJSON o = do "_" <- readJSON o; return Anonymous
+  readJSON o = do parseString "_" o; return Anonymous
     <|>        VarId <$> readJSON o
 
 instance JSON QualId where
@@ -268,6 +269,9 @@ instance JSON FlagValue where
 --------------------------------------------------------------------------------
 -- ** 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

src/compiler/GF/Grammar/EBNF.hs

@@ -16,6 +16,7 @@ module GF.Grammar.EBNF (EBNF, ERule, ERHS(..), ebnf2cf) where
 
 import GF.Data.Operations
 import GF.Grammar.CFG
+import PGF (mkCId)
 
 type EBNF = [ERule]
 type ERule = (ECat, ERHS)
@@ -39,7 +40,7 @@ ebnf2cf :: EBNF -> [ParamCFRule]
 ebnf2cf ebnf = 
   [Rule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)]
   where
-    mkCFF i (c,_) = CFObj ("Mk" ++ c ++ "_" ++ show i) []
+    mkCFF i (c,_) = CFObj (mkCId ("Mk" ++ c ++ "_" ++ show i)) []
 
 normEBNF :: EBNF -> [CFJustRule]
 normEBNF erules = let

src/compiler/GF/Grammar/Grammar.hs

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
+        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence
         ) where
 
 import GF.Infra.Ident
@@ -73,8 +73,7 @@ import GF.Infra.Location
 
 import GF.Data.Operations
 
-import PGF2(LIndex, BindType(..))
-import PGF2.Internal(FId, FunId, SeqId, Symbol)
+import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -100,7 +99,7 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Array SeqId [Symbol]),
+    mseqs   :: Maybe (Array SeqId Sequence),
     jments  :: Map.Map Ident Info
   }
 
@@ -330,7 +329,7 @@ data Info =
 
 -- judgements in resource
  | ResParam (Maybe (L [Param])) (Maybe [Term])   -- ^ (/RES/) the second parameter is list of all possible values
- | ResValue (L Type) Int                         -- ^ (/RES/) to mark parameter constructors for lookup
+ | ResValue (L Type)                             -- ^ (/RES/) to mark parameter constructors for lookup
  | ResOper  (Maybe (L Type)) (Maybe (L Term))    -- ^ (/RES/)
 
  | ResOverload [ModuleName] [(L Type,L Term)]         -- ^ (/RES/) idents: modules inherited
@@ -459,7 +458,7 @@ type Case = (Patt, Term)
 --type Cases = ([Patt], Term) 
 type LocalDef = (Ident, (Maybe Type, Term))
 
-type Param = (Ident, Context, Int) 
+type Param = (Ident, Context) 
 type Altern = (Term, [(Term, Term)])
 
 type Substitution =  [(Ident, Term)]

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

@@ -23,11 +23,10 @@ module GF.Grammar.Lookup (
            lookupResType, 
            lookupOverload,
            lookupOverloadTypes,
-           lookupParamValues,
+           lookupParamValues, 
            allParamValues,
-           lookupParamValueIndex,
-           lookupAbsDef,
-           lookupLincat,
+           lookupAbsDef, 
+           lookupLincat, 
            lookupFunType,
            lookupCatContext,
            allOpers, allOpersTo
@@ -84,7 +83,7 @@ lookupResDefLoc gr (m,c)
 
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (noLoc (QC (m,c)))
-        ResValue _ _      -> return (noLoc (QC (m,c)))
+        ResValue _        -> return (noLoc (QC (m,c)))
         _   -> raise $ render (c <+> "is not defined in resource" <+> m)
 
 lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
@@ -100,7 +99,7 @@ lookupResType gr (m,c) = do
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _      -> return typePType
-    ResValue (L _ t) _-> return t
+    ResValue (L _ t)  -> return t
     _   -> raise $ render (c <+> "has no type defined in resource" <+> m)
 
 lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
@@ -114,8 +113,8 @@ lookupOverloadTypes gr id@(m,c) = do
     CncFun (Just (cat,cont,val)) _ _ _ -> do
           val' <- lock cat val 
           ret $ mkProd cont val' []
-    ResParam _ _       -> ret typePType
-    ResValue (L _ t) _ -> ret t
+    ResParam _ _      -> ret typePType
+    ResValue (L _ t)  -> ret t
     ResOverload os tysts -> do
             tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
             return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
@@ -167,23 +166,16 @@ 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
     sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
 
-lookupParamValueIndex :: ErrorMonad m => Grammar -> QIdent -> m Int
-lookupParamValueIndex gr c = do
-  (_,info) <- lookupOrigInfo gr c
-  case info of
-    ResValue _ i -> return i
-    _            -> raise $ render (ppQIdent Qualified c <+> "has no parameter index defined")
-
 lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
 lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
   info <- lookupQIdentInfo gr (m,c)
@@ -234,7 +226,7 @@ allOpers gr =
     typesIn info = case info of
       AbsFun  (Just ltyp) _ _ _ -> [ltyp]
       ResOper (Just ltyp) _     -> [ltyp]
-      ResValue ltyp _           -> [ltyp]
+      ResValue ltyp             -> [ltyp]
       ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
       CncFun  (Just (i,ctx,typ)) _ _ _ ->
                                    [L NoLoc (mkProdSimple ctx (lock' i typ))]

src/compiler/GF/Grammar/Macros.hs

@@ -32,6 +32,7 @@ import Control.Monad (liftM, liftM2, liftM3)
 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.
 
@@ -47,7 +48,7 @@ typeForm t =
     Q  c -> ([],c,[])
     QC c -> ([],c,[])
     Sort c -> ([],(MN identW, c),[])
-    _      -> error (render ("no normal form of type" <+> show t))
+    _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
 
 typeFormCnc :: Type -> (Context, Type)
 typeFormCnc t = 
@@ -237,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)
@@ -554,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
@@ -614,15 +611,13 @@ allDependencies ism b =
     opersIn t = case t of
       Q  (n,c) | ism n -> [c]
       QC (n,c) | ism n -> [c]
-      Cn c             -> [c]
       _ -> collectOp opersIn t
     opty (Just (L _ ty)) = opersIn ty
     opty _ = []
     pts i = case i of
       ResOper pty pt -> [pty,pt]
       ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
-      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont,_) <- ps, (_,_,t) <- cont]
-      ResValue pty _ -> [Just pty]
+      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
       CncCat pty _ _ _ _ -> [pty]
       CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
       AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual

src/compiler/GF/Grammar/Parser.y

@@ -25,6 +25,7 @@ import GF.Compile.Update (buildAnyTree)
 import Data.List(intersperse)
 import Data.Char(isAlphaNum)
 import qualified Data.Map as Map
+import PGF(mkCId)
 
 }
 
@@ -267,7 +268,7 @@ DataDef
 ParamDef :: { [(Ident,Info)] }
 ParamDef
   : Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
-                                        [(f, ResValue (L loc (mkProdSimple co (Cn $2))) i) | L loc (f,co,i) <- $4] }
+                                        [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
   | Posn LhsIdent                   Posn { [($2, ResParam Nothing Nothing)] }
 
 OperDef :: { [(Ident,Info)] }
@@ -302,7 +303,7 @@ ListDataConstr
 
 ParConstr :: { L Param }
 ParConstr
-  : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3,0) } 
+  : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) } 
 
 ListLinDef :: { [(Ident,Info)] }
 ListLinDef
@@ -624,7 +625,7 @@ ListCFRule
 
 CFRule :: { [BNFCRule] }
 CFRule
-  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
+  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
                                            }
   | Ident '::=' ListCFRHS ';'              { let { cat = showIdent $1;
                                                    mkFun cat its =
@@ -637,7 +638,7 @@ CFRule
                                                        Terminal    c     -> filter isAlphaNum c;
                                                        NonTerminal (t,_) -> t
                                                      }
-                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
+                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
                                            }
   | 'coercions' Ident Integer ';'          { [BNFCCoercions (showIdent $2) $3]}
   | 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }
@@ -774,7 +775,7 @@ checkInfoType mt jment@(id,info) =
     CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
     CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
     ResParam pparam _    -> ifResource mt (locPerh pparam)
-    ResValue ty _        -> ifResource mt (locL ty)
+    ResValue ty          -> ifResource mt (locL ty)
     ResOper  pty pt      -> ifOper mt pty pt
     ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where

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
-      (PV x,  _) | isInConstantFormt -> return [(x,t)]
+      (PW, _) -> return [] -- optimization with wildcard
+      (PV x,([],K s,[])) -> return [(x,words2term (words s))]
+      (PV x,  _) -> return [(x,t)]
       (PString s, ([],K i,[])) | s==i -> return []
       (PInt s, ([],EInt i,[])) | s==i -> return []
       (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
@@ -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

@@ -22,17 +22,21 @@ module GF.Grammar.Printer
            , ppMeta
            , getAbs
            ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
-import PGF2 as PGF2
-import PGF2.Internal as PGF2
 import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.Values
 import GF.Grammar.Grammar
+
+import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
+
 import GF.Text.Pretty
 import Data.Maybe (isNothing)
 import Data.List  (intersperse)
 import qualified Data.Map as Map
+--import qualified Data.IntMap as IntMap
+--import qualified Data.Set as Set
 import qualified Data.Array.IArray as Array
 
 data TermPrintQual 
@@ -106,8 +110,8 @@ ppJudgement q (id, ResParam pparams _) =
   (case pparams of
      Just (L _ ps) -> '=' <+> ppParams q ps
      _             -> empty) <+> ';'
-ppJudgement q (id, ResValue pvalue i) = 
-  "-- param constructor" <+> "[index" <+> i <> "]" <+> id <+> ':' <+> 
+ppJudgement q (id, ResValue pvalue) = 
+  "-- param constructor" <+> id <+> ':' <+> 
   (case pvalue of
      (L _ ty) -> ppTerm q 0 ty) <+> ';'
 ppJudgement q (id, ResOper  ptype pexp) =
@@ -322,7 +326,7 @@ ppBind (Implicit,v) = braces v
 ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 
 ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
-ppParam q (id,cxt,_) = id <+> hsep (map (ppDDecl q) cxt)
+ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
 
 ppProduction (Production fid funid args) =
   ppFId fid <+> "->" <+> ppFunId funid <> 
@@ -359,39 +363,3 @@ getLet (Let l e) = let (ls,e') = getLet e
                    in (l:ls,e')
 getLet e         = ([],e)
 
-ppFunId funid = pp 'F' <> pp funid
-ppSeqId seqid = pp 'S' <> pp seqid
-
-ppFId fid
-  | fid == PGF2.fidString = pp "CString"
-  | fid == PGF2.fidInt    = pp "CInt"
-  | fid == PGF2.fidFloat  = pp "CFloat"
-  | fid == PGF2.fidVar    = pp "CVar"
-  | fid == PGF2.fidStart  = pp "CStart"
-  | otherwise             = pp 'C' <> pp fid
-
-ppMeta :: Int -> Doc
-ppMeta n
-  | n == 0    = pp '?'
-  | otherwise = pp '?' <> pp n
-
-ppLit (PGF2.LStr s) = pp (show s)
-ppLit (PGF2.LInt n) = pp n
-ppLit (PGF2.LFlt d) = pp d
-
-ppSeq (seqid,seq) = 
-  ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq)
-
-ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>'
-ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
-ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
-ppSymbol (PGF2.SymKS t)    = doubleQuotes (pp t)
-ppSymbol PGF2.SymNE        = pp "nonExist"
-ppSymbol PGF2.SymBIND      = pp "BIND"
-ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
-ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE"
-ppSymbol PGF2.SymCAPIT     = pp "CAPIT"
-ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
-ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
-
-ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

src/compiler/GF/Infra/BuildInfo.hs

@@ -14,3 +14,9 @@ buildInfo =
 #ifdef SERVER_MODE
     ++" server"
 #endif
+#ifdef NEW_COMP
+    ++" new-comp"
+#endif
+#ifdef C_RUNTIME
+    ++" c-runtime"
+#endif

src/compiler/GF/Infra/CheckM.hs

@@ -18,6 +18,7 @@ module GF.Infra.CheckM
 	   checkIn, checkInModule, checkMap, checkMapRecover,
            parallelCheck, accumulateError, commitCheck,
 	  ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Data.Operations
 --import GF.Infra.Ident
@@ -31,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
@@ -52,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/Ident.hs

@@ -13,17 +13,17 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- ** Identifiers
-          ModuleName(..), moduleNameS,
-          Ident, ident2utf8, showIdent, prefixIdent,
-          -- *** Normal identifiers (returned by the parser)
-          identS, identC, identW,
-          -- *** Special identifiers for internal use
-          identV, identA, identAV,
-          argIdent, isArgIdent, getArgIndex,
-          varStr, varX, isWildIdent, varIndex,
-          -- *** Raw identifiers
-          RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-          isPrefixOf, showRawIdent
+              ModuleName(..), moduleNameS,
+	      Ident, ident2utf8, showIdent, prefixIdent,
+              -- *** Normal identifiers (returned by the parser)
+	      identS, identC, identW,
+              -- *** Special identifiers for internal use
+              identV, identA, identAV,
+	      argIdent, isArgIdent, getArgIndex,
+              varStr, varX, isWildIdent, varIndex,
+              -- *** Raw identifiers
+              RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+              isPrefixOf, showRawIdent
 	     ) where
 
 import qualified Data.ByteString.UTF8 as UTF8
@@ -31,7 +31,7 @@ import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
                  -- Limit use of BS functions to the ones that work correctly on
                  -- UTF-8-encoded bytestrings!
 import Data.Char(isDigit)
-import Data.Binary(Binary(..))
+import PGF.Internal(Binary(..))
 import GF.Text.Pretty
 
 

src/compiler/GF/Infra/Location.hs

@@ -1,5 +1,6 @@
 -- | Source locations
 module GF.Infra.Location where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import GF.Text.Pretty
 
 -- ** Source locations

src/compiler/GF/Infra/Option.hs

@@ -2,13 +2,13 @@ module GF.Infra.Option
     (
      -- ** Command line options
      -- *** Option types
-     Options, 
-     Flags(..), 
-     Mode(..), Phase(..), Verbosity(..), 
-     OutputFormat(..), 
+     Options,
+     Flags(..),
+     Mode(..), Phase(..), Verbosity(..),
+     OutputFormat(..),
      SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
      Dump(..), Pass(..), Recomp(..),
-     outputFormatsExpl, 
+     outputFormatsExpl,
      -- *** Option parsing
      parseOptions, parseModuleOptions, fixRelativeLibPaths,
      -- *** Option pretty-printing
@@ -34,16 +34,20 @@ import Data.Maybe
 import GF.Infra.Ident
 import GF.Infra.GetOpt
 import GF.Grammar.Predef
+--import System.Console.GetOpt
 import System.FilePath
-import PGF2.Internal(Literal(..))
+--import System.IO
 
 import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
 
 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:",
@@ -72,6 +76,7 @@ errors = raise . unlines
 
 data Mode = ModeVersion | ModeHelp
           | ModeInteractive | ModeRun
+          | ModeInteractive2 | ModeRun2
           | ModeCompiler
           | ModeServer {-port::-}Int
   deriving (Show,Eq,Ord)
@@ -82,49 +87,53 @@ data Verbosity = Quiet | Normal | Verbose | Debug
 data Phase = Preproc | Convert | Compile | Link
   deriving (Show,Eq,Ord)
 
-data OutputFormat = FmtPGFPretty
+data OutputFormat = FmtLPGF
+                  | FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
+                  | FmtJavaScript
                   | FmtJSON
-                  | FmtHaskell 
+                  | FmtPython
+                  | FmtHaskell
                   | FmtJava
+                  | FmtProlog
                   | FmtBNF
                   | FmtEBNF
                   | FmtRegular
                   | FmtNoLR
                   | FmtSRGS_XML
                   | FmtSRGS_XML_NonRec
-                  | FmtSRGS_ABNF 
+                  | FmtSRGS_ABNF
                   | FmtSRGS_ABNF_NonRec
-                  | FmtJSGF 
-                  | FmtGSL 
+                  | FmtJSGF
+                  | FmtGSL
                   | FmtVoiceXML
                   | FmtSLF
                   | FmtRegExp
                   | FmtFA
   deriving (Eq,Ord)
 
-data SISRFormat = 
+data SISRFormat =
     -- | SISR Working draft 1 April 2003
     --   <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
-    SISR_WD20030401    
+    SISR_WD20030401
   | SISR_1_0
  deriving (Show,Eq,Ord)
 
 data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
   deriving (Show,Eq,Ord)
 
-data CFGTransform = CFGNoLR 
+data CFGTransform = CFGNoLR
                   | CFGRegular
-                  | CFGTopDownFilter 
-                  | CFGBottomUpFilter 
+                  | CFGTopDownFilter
+                  | CFGBottomUpFilter
                   | CFGStartCatOnly
                   | CFGMergeIdentical
                   | CFGRemoveCycles
   deriving (Show,Eq,Ord)
 
 data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
-                   | HaskellConcrete | HaskellVariants
+                   | HaskellConcrete | HaskellVariants | HaskellData
   deriving (Show,Eq,Ord)
 
 data Warning = WarnMissingLincat
@@ -149,7 +158,7 @@ data Flags = Flags {
       optLiteralCats     :: Set Ident,
       optGFODir          :: Maybe FilePath,
       optOutputDir       :: Maybe FilePath,
-      optGFLibPath       :: Maybe FilePath,
+      optGFLibPath       :: Maybe [FilePath],
       optDocumentRoot    :: Maybe FilePath, -- For --server mode
       optRecomp          :: Recomp,
       optProbsFile       :: Maybe FilePath,
@@ -188,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)
@@ -200,13 +209,14 @@ 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
 
-fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
+fixRelativeLibPaths curr_dir lib_dirs (Options o) = Options (fixPathFlags . o)
   where
-    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
+    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [parent </> dir
+                                                                                      | parent <- curr_dir : lib_dirs]) path}
 
 -- Showing options
 
@@ -272,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,
@@ -292,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.",
@@ -302,6 +312,8 @@ optDescr =
      Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
      Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
      Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
+     Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.",
+     Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).",
      Option [] ["server"] (OptArg modeServer "port") $
        "Run in HTTP server mode on given port (default "++show defaultPort++").",
      Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
@@ -316,44 +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:",
                   "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
-                  "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
+                  "Multiple concrete: pgf (default), lpgf, json, js, pgf_pretty, prolog, python, ...", -- gar,
                   "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
                   "Abstract only: haskell, ..."]), -- prolog_abs,
-     Option [] ["sisr"] (ReqArg sisrFmt "FMT") 
+     Option [] ["sisr"] (ReqArg sisrFmt "FMT")
         (unlines ["Include SISR tags in generated speech recognition grammars.",
                   "FMT can be one of: old, 1.0"]),
-     Option [] ["haskell"] (ReqArg hsOption "OPTION") 
-            ("Turn on an optional feature when generating Haskell data types. OPTION = " 
+     Option [] ["haskell"] (ReqArg hsOption "OPTION")
+            ("Turn on an optional feature when generating Haskell data types. OPTION = "
              ++ concat (intersperse " | " (map fst haskellOptionNames))),
-     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") 
+     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
             "Treat CAT as a lexical category.",
-     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") 
+     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
             "Treat CAT as a literal category.",
-     Option ['D'] ["output-dir"] (ReqArg outDir "DIR") 
+     Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
            "Save output files (other than .gfo files) in DIR.",
-     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") 
+     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
            "Overrides the value of GF_LIB_PATH.",
-     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) 
+     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
                  "Always recompile from source.",
-     Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer)) 
+     Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
                  "(default) Recompile from source if the source is newer than the .gfo file.",
-     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) 
+     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
                  "Never recompile from source, if there is already .gfo file.",
      Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
      Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
-     Option ['n'] ["name"] (ReqArg name "NAME") 
+     Option ['n'] ["name"] (ReqArg name "NAME")
            (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
                      "with suffixes depending on the formats, and, when relevant, ",
                      "internally in the output."]),
      Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
      Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
-     Option [] ["preproc"] (ReqArg preproc "CMD") 
+     Option [] ["preproc"] (ReqArg preproc "CMD")
                  (unlines ["Use CMD to preprocess input files.",
                            "Multiple preprocessors can be used by giving this option multiple times."]),
-     Option [] ["coding"] (ReqArg coding "ENCODING") 
+     Option [] ["coding"] (ReqArg coding "ENCODING")
                 ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
      Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
      Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
@@ -361,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",
@@ -416,7 +428,7 @@ optDescr =
        literalCat  x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
        lexicalCat  x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
        outDir      x = set $ \o -> o { optOutputDir = Just x }
-       gfLibPath   x = set $ \o -> o { optGFLibPath = Just x }
+       gfLibPath   x = set $ \o -> o { optGFLibPath = Just $ splitInModuleSearchPath x }
        gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
@@ -436,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 }
 
@@ -460,13 +472,17 @@ outputFormats :: [(String,OutputFormat)]
 outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
-outputFormatsExpl = 
-    [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
+outputFormatsExpl =
+    [(("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)"),
+     (("prolog",       FmtProlog),"Prolog (whole grammar)"),
      (("bnf",          FmtBNF),"BNF (context-free grammar)"),
      (("ebnf",         FmtEBNF),"Extended BNF"),
      (("regular",      FmtRegular),"* regular grammar"),
@@ -490,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]),
@@ -502,7 +518,7 @@ optimizationPackages =
     ]
 
 cfgTransformNames :: [(String, CFGTransform)]
-cfgTransformNames = 
+cfgTransformNames =
     [("nolr",         CFGNoLR),
      ("regular",      CFGRegular),
      ("topdown",      CFGTopDownFilter),
@@ -517,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
@@ -534,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
@@ -542,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 s = 
+readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
+readOutputFormat s =
     maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
 
 -- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -555,7 +572,7 @@ splitInModuleSearchPath s = case break isPathSep s of
     isPathSep :: Char -> Bool
     isPathSep c = c == ':' || c == ';'
 
--- 
+--
 -- * Convenience functions for checking options
 --
 
@@ -577,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
 --
 
@@ -608,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                      
-                   in if i >= fromEnum mi && i <= fromEnum ma 
+                      ma = maxBound `asTypeOf` mi
+                   in if i >= fromEnum mi && i <= fromEnum ma
                         then Just (toEnum i `asTypeOf` mi)
                         else Nothing
 

src/compiler/GF/Infra/SIO.hs

@@ -12,6 +12,9 @@ module GF.Infra.SIO(
        newStdGen,print,putStr,putStrLn,
        -- ** Specific to GF
        importGrammar,importSource,
+#ifdef C_RUNTIME
+       readPGF2,
+#endif
        putStrLnFlush,runInterruptibly,lazySIO,
        -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
        -- | If the environment variable GF_RESTRICTED is defined, these
@@ -36,6 +39,10 @@ import qualified System.Random as IO(newStdGen)
 import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
 import qualified GF.System.Signal as IO(runInterruptibly)
 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
 
@@ -52,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
@@ -117,3 +127,7 @@ lazySIO              = lift1   lazyIO
 
 importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
 importSource      opts files = lift0 $ GF.importSource      opts files
+
+#ifdef C_RUNTIME
+readPGF2 = lift0 . PGF2.readPGF
+#endif

src/compiler/GF/Infra/UseIO.hs

@@ -38,6 +38,7 @@ import Control.Monad(when,liftM,foldM)
 import Control.Monad.Trans(MonadIO(..))
 import Control.Monad.State(StateT,lift)
 import Control.Exception(evaluate)
+import Data.List (nub)
 
 --putIfVerb :: MonadIO io => Options -> String -> io ()
 putIfVerb opts msg = when (verbAtLeast opts Verbose) $ putStrLnE msg
@@ -51,28 +52,32 @@ type FullPath = String
 gfLibraryPath    = "GF_LIB_PATH"
 gfGrammarPathVar = "GF_GRAMMAR_PATH"
 
-getLibraryDirectory :: MonadIO io => Options -> io FilePath
+getLibraryDirectory :: MonadIO io => Options -> io [FilePath]
 getLibraryDirectory opts =
   case flag optGFLibPath opts of
     Just path -> return path
-    Nothing   -> liftIO $ catch (getEnv gfLibraryPath)
-                                (\ex -> fmap (</> "lib") getDataDir)
+    Nothing   -> liftM splitSearchPath $ liftIO (catch (getEnv gfLibraryPath)
+                                                (\ex -> fmap (</> "lib") getDataDir))
 
-getGrammarPath :: MonadIO io => FilePath -> io [FilePath]
-getGrammarPath lib_dir = liftIO $ do
+getGrammarPath :: MonadIO io => [FilePath] -> io [FilePath]
+getGrammarPath lib_dirs = liftIO $ do
   catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) 
-        (\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"])     -- e.g. GF_GRAMMAR_PATH
+        (\_ -> return $ concat [[lib_dir </> "alltenses", lib_dir </> "prelude"]
+                               | lib_dir <- lib_dirs ])     -- e.g. GF_GRAMMAR_PATH
 
 -- | extends the search path with the
 -- 'gfLibraryPath' and 'gfGrammarPathVar'
 -- environment variables. Returns only existing paths.
 extendPathEnv :: MonadIO io => Options -> io [FilePath]
 extendPathEnv opts = liftIO $ do
-  let opt_path = flag optLibraryPath opts         -- e.g. paths given as options
-  lib_dir  <- getLibraryDirectory opts                  -- e.g. GF_LIB_PATH
-  grm_path <- getGrammarPath lib_dir                   -- e.g. GF_GRAMMAR_PATH
-  let paths = opt_path ++ [lib_dir] ++ grm_path
-  ps <- liftM concat $ mapM allSubdirs paths
+  let opt_path = nub $ flag optLibraryPath opts         -- e.g. paths given as options
+  lib_dirs <- getLibraryDirectory opts                  -- e.g. GF_LIB_PATH
+  grm_path <- getGrammarPath lib_dirs                   -- e.g. GF_GRAMMAR_PATH
+  let paths = opt_path ++ lib_dirs ++ grm_path
+  when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: opt_path is "++ show opt_path)
+  when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: lib_dirs is "++ show lib_dirs)
+  when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: grm_path is "++ show grm_path)
+  ps <- liftM (nub . concat) $ mapM allSubdirs (nub paths)
   mapM canonicalizePath ps
   where
     allSubdirs :: FilePath -> IO [FilePath]
@@ -80,11 +85,15 @@ extendPathEnv opts = liftIO $ do
     allSubdirs p = case last p of
       '*' -> do let path = init p
                 fs <- getSubdirs path
-                return [path </> f | f <- fs]
+                let starpaths = [path </> f | f <- fs]
+                when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: * found "++show starpaths)
+                return starpaths
       _   -> do exists <- doesDirectoryExist p
                 if exists
-                  then return [p]
-                  else do when (verbAtLeast opts Verbose) $ putStrLn ("ignore path "++p)
+                  then do
+                       when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: found path "++show p)
+                       return [p]
+                  else do when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: ignore path "++ show p)
                           return []
 
 getSubdirs :: FilePath -> IO [FilePath]
@@ -150,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
@@ -161,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

@@ -5,14 +5,14 @@ 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.Commands(HasPGF(..),pgfCommands)
+import GF.Command.Commands(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands)
 import GF.Command.CommonCommands(commonCommands,extend)
 import GF.Command.SourceCommands
 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)
@@ -20,12 +20,15 @@ import GF.Infra.SIO
 import GF.Infra.Option
 import qualified System.Console.Haskeline as Haskeline
 
-import PGF2
+import PGF
+import PGF.Internal(abstract,funs,lookStartCat,emptyPGF)
 
 import Data.Char
 import Data.List(isPrefixOf)
 import qualified Data.Map as Map
 import qualified Text.ParserCombinators.ReadP as RP
+--import System.IO(utf8)
+--import System.CPUTime(getCPUTime)
 import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
 import Control.Exception(SomeException,fromException,evaluate,try)
 import Control.Monad.State hiding (void)
@@ -35,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 ()
@@ -96,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"
@@ -159,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 _   =
@@ -274,19 +280,18 @@ importInEnv opts files =
      if flag optRetainResource opts
       then do src <- lift $ importSource opts files
               pgf <- lift . lazySIO $ importPGF pgf0 -- duplicates some work, better to link src
-              modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgf)}
+              modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgfEnv pgf)}
       else do pgf1 <- lift $ importPGF pgf0
               modify $ \ gfenv->gfenv { retain=False,
-                                        pgfenv = (emptyGrammar,pgf1) }
+                                        pgfenv = (emptyGrammar,pgfEnv pgf1) }
   where
     importPGF pgf0 =
       do let opts' = addOptions (setOptimization OptCSE False) opts
          pgf1 <- importGrammar pgf0 opts' files
          if (verbAtLeast opts Normal)
-           then case pgf1 of
-                  Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
-                  Nothing  -> done
-           else done
+           then putStrLnFlush $
+                  unwords $ "\nLanguages:" : map showCId (languages pgf1)
+           else return ()
          return pgf1
 
 tryGetLine = do
@@ -296,12 +301,12 @@ tryGetLine = do
    Right l -> return l
 
 prompt env
-  | retain env = "> "
-  | otherwise  = case multigrammar env of
-                   Just pgf -> abstractName pgf ++ "> "
-                   Nothing  -> "> "
+  | retain env || abs == wildCId = "> "
+  | otherwise      = showCId abs ++ "> "
+  where
+    abs = abstractName (multigrammar env)
 
-type CmdEnv = (Grammar,Maybe PGF)
+type CmdEnv = (Grammar,PGFEnv)
 
 data GFEnv = GFEnv {
     startOpts :: Options,
@@ -313,10 +318,10 @@ data GFEnv = GFEnv {
 
 emptyGFEnv opts = GFEnv opts False emptyCmdEnv emptyCommandEnv []
 
-emptyCmdEnv = (emptyGrammar,Nothing)
+emptyCmdEnv = (emptyGrammar,pgfEnv emptyPGF)
 
 emptyCommandEnv = mkCommandEnv allCommands
-multigrammar = snd . pgfenv
+multigrammar = pgf . snd . pgfenv
 
 allCommands =
   extend pgfCommands (helpCommand allCommands:moreCommands)
@@ -324,35 +329,24 @@ allCommands =
   `Map.union` commonCommands
 
 instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv)
-instance HasPGF ShellM where getPGF = gets (snd . pgfenv)
+instance HasPGFEnv ShellM where getPGFEnv = gets (snd . pgfenv)
 
 wordCompletion gfenv (left,right) = do
   case wc_type (reverse left) of
     CmplCmd pref
       -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
     CmplStr (Just (Command _ opts _)) s0
-      -> case multigrammar gfenv of
-           Just pgf -> let langs = languages pgf
-                           optLang opts = case valStrOpts "lang" "" opts of
-                                            ""   -> case Map.minView langs of
-                                                      Nothing        -> Nothing
-                                                      Just (concr,_) -> Just concr
-                                            lang -> mplus (Map.lookup lang                       langs)
-                                                          (Map.lookup (abstractName pgf ++ lang) langs)
-                           optType opts = let readOpt str = case readType str of
-                                                              Just ty -> case checkType pgf ty of
-                                                                           Left _   -> Nothing
-                                                                           Right ty -> Just ty
-                                                              Nothing -> Nothing
-                                          in maybeStrOpts "cat" (Just (startCat pgf)) readOpt opts
-                           (rprefix,rs) = break isSpace (reverse s0)
-                           s            = reverse rs
-                           prefix       = reverse rprefix
-                       in case (optLang opts, optType opts) of
-                            (Just lang,Just cat) -> let compls = [t | (t,_,_,_) <- complete lang cat s prefix]
-                                                    in ret (length prefix) (map Haskeline.simpleCompletion compls)
-                            _                    -> ret 0 []
-           Nothing  -> ret 0 []
+      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts)))
+            case mb_state0 of
+              Right state0 -> let (rprefix,rs) = break isSpace (reverse s0)
+                                  s            = reverse rs
+                                  prefix       = reverse rprefix
+                                  ws           = words s
+                              in case loop state0 ws of
+                                   Nothing    -> ret 0 []
+                                   Just state -> let compls = getCompletions state prefix
+                                                 in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls))
+              Left (_ :: SomeException) -> ret 0 []
     CmplOpt (Just (Command n _ _)) pref
       -> case Map.lookup n (commands cmdEnv) of
            Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags   inf, isPrefixOf pref flg]
@@ -363,15 +357,23 @@ wordCompletion gfenv (left,right) = do
     CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
       -> Haskeline.completeFilename (left,right)
     CmplIdent _ pref
-      -> case multigrammar gfenv of
-           Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
-           Nothing  -> ret (length pref) []
+      -> do mb_abs <- try (evaluate (abstract pgf))
+            case mb_abs of
+              Right abs -> ret (length pref) [Haskeline.simpleCompletion name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name]
+              Left (_ :: SomeException) -> ret (length pref) []
     _ -> ret 0 []
   where
+    pgf    = multigrammar gfenv
     cmdEnv = commandenv gfenv
+    optLang opts = valCIdOpts "lang" (head (languages pgf)) opts
+    optType opts =
+      let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
+      in case readType str of
+           Just ty -> ty
+           Nothing -> error ("Can't parse '"++str++"' as type")
 
     loop ps []     = Just ps
-    loop ps (t:ts) = case error "nextState ps (simpleParseInput t)" of
+    loop ps (t:ts) = case nextState ps (simpleParseInput t) of
                        Left  es -> Nothing
                        Right ps -> loop ps ts
 
@@ -411,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
 
@@ -429,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

@@ -0,0 +1,442 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
+-- | GF interactive mode (with the C run-time system)
+module GF.Interactive2 (mainGFI,mainRunGFI{-,mainServerGFI-}) where
+import Prelude hiding (putStrLn,print)
+import qualified Prelude as P(putStrLn)
+import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,interpretCommandLine)
+import GF.Command.Commands2(PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands)
+import GF.Command.CommonCommands
+import GF.Command.CommandInfo
+import GF.Command.Help(helpCommand)
+import GF.Command.Abstract
+import GF.Command.Parse(readCommandLine,pCommand)
+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 qualified PGF2 as C
+import qualified PGF as H
+
+import Data.Char
+import Data.List(isPrefixOf)
+import qualified Data.Map as Map
+
+import qualified Text.ParserCombinators.ReadP as RP
+--import System.IO(utf8)
+--import System.CPUTime(getCPUTime)
+import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
+import System.FilePath(takeExtensions)
+import Control.Exception(SomeException,fromException,try)
+--import Control.Monad
+import Control.Monad.State hiding (void)
+
+import qualified GF.System.Signal as IO(runInterruptibly)
+{-
+#ifdef SERVER_MODE
+import GF.Server(server)
+#endif
+-}
+
+import GF.Command.Messages(welcome)
+
+-- | Run the GF Shell in quiet mode (@gf -run@).
+mainRunGFI :: Options -> [FilePath] -> IO ()
+mainRunGFI opts files = shell (beQuiet opts) files
+
+beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet}))
+
+-- | Run the interactive GF Shell
+mainGFI :: Options -> [FilePath] -> IO ()
+mainGFI opts files = do
+  P.putStrLn welcome
+  P.putStrLn "This shell uses the C run-time system. See help for available commands."
+  shell opts files
+
+shell opts files = flip evalStateT (emptyGFEnv opts) $
+                   do mapStateT runSIO $ importInEnv opts files
+                      loop
+
+{-
+#ifdef SERVER_MODE
+-- | Run the GF Server (@gf -server@).
+-- The 'Int' argument is the port number for the HTTP service.
+mainServerGFI opts0 port files =
+    server jobs port root (execute1 opts)
+      =<< runSIO (importInEnv (emptyGFEnv opts) opts files)
+  where
+    root = flag optDocumentRoot opts
+    opts = beQuiet opts0
+    jobs = join (flag optJobs opts)
+#else
+mainServerGFI opts port files =
+  error "GF has not been compiled with server mode support"
+#endif
+-}
+-- | Read end execute commands until it is time to quit
+loop :: StateT GFEnv IO ()
+loop = repeatM readAndExecute1
+
+-- | Read and execute one command, returning 'True' to continue execution,
+-- | 'False' when it is time to quit
+readAndExecute1 :: StateT GFEnv IO Bool
+readAndExecute1 = mapStateT runSIO . execute1 =<< readCommand
+
+-- | Read a command
+readCommand :: StateT GFEnv IO String
+readCommand =
+  do opts <- gets startOpts
+     case flag optMode opts of
+       ModeRun -> lift tryGetLine
+       _       -> lift . fetchCommand =<< get
+
+timeIt act =
+  do t1 <- liftSIO $ getCPUTime
+     a <-  act
+     t2 <- liftSIO $ getCPUTime
+     return (t2-t1,a)
+
+-- | 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 
+  | not (verbAtLeast opts Normal) = act
+  | otherwise = do (dt,r) <- timeIt act
+                   liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
+                   return r
+
+type ShellM = StateT GFEnv SIO
+
+-- | Execute a given command line, returning 'True' to continue execution,
+-- | 'False' when it is time to quit
+execute1 :: String -> ShellM Bool
+execute1 s0 =
+  do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0}
+     execute1' s0
+
+-- | Execute a given command line, without adding it to the history
+execute1' s0 =
+  do opts <- gets startOpts
+     interruptible $ optionallyShowCPUTime opts $
+       case pwords s0 of
+      -- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands
+      -- special commands
+         "q" :_   -> quit
+         "!" :ws  -> system_command ws
+         "eh":ws  -> execute_history ws
+         "i" :ws  -> do import_ ws; continue
+      -- other special commands, working on GFEnv
+         "dc":ws  -> define_command ws
+         "dt":ws  -> define_tree ws
+      -- ordinary commands
+         _        -> do env <- gets commandenv
+                        interpretCommandLine env s0
+                        continue
+  where
+    continue,stop :: ShellM Bool
+    continue = return True
+    stop = return False
+
+    interruptible :: ShellM Bool -> ShellM Bool
+    interruptible act =
+      do gfenv <- get
+         mapStateT (
+           either (\e -> printException e >> return (True,gfenv)) return
+             <=< runInterruptibly) act
+
+  -- Special commands:
+
+    quit = do opts <- gets startOpts
+              when (verbAtLeast opts Normal) $ putStrLnE "See you."
+              stop
+
+    system_command ws = do lift $ restrictedSystem $ unwords ws ; continue
+
+
+       {-"eh":w:_ -> do
+                  cs <- readFile w >>= return . map words . lines
+                  gfenv' <- foldM (flip (process False benv)) gfenv cs
+                  loopNewCPU gfenv' -}
+    execute_history [w] =
+      do execute . lines =<< lift (restricted (readFile w))
+         continue
+      where
+        execute :: [String] -> ShellM ()
+        execute [] = return ()
+        execute (line:lines) = whenM (execute1' line) (execute lines)
+
+    execute_history _   =
+       do putStrLnE "eh command not parsed"
+          continue
+
+    define_command (f:ws) =
+        case readCommandLine (unwords ws) of
+           Just comm ->
+             do modify $
+                  \ gfenv ->
+                    let env = commandenv gfenv
+                    in gfenv {
+                         commandenv = env {
+                           commandmacros = Map.insert f comm (commandmacros env)
+                         }
+                       }
+                continue
+           _ -> dc_not_parsed
+    define_command _ = dc_not_parsed
+
+    dc_not_parsed = putStrLnE "command definition not parsed" >> continue
+
+    define_tree (f:ws) =
+        case H.readExpr (unwords ws) of
+          Just exp ->
+           do modify $
+                \ gfenv ->
+                  let env = commandenv gfenv
+                  in gfenv { commandenv = env {
+                               expmacros = Map.insert f exp (expmacros env) } }
+              continue
+          _ -> dt_not_parsed
+    define_tree _ = dt_not_parsed
+
+    dt_not_parsed = putStrLnE "value definition not parsed" >> continue
+
+pwords s = case words s of
+             w:ws -> getCommandOp w :ws
+             ws -> ws
+import_ args =
+  do case parseOptions args of
+       Ok (opts',files) -> do
+         opts <- gets startOpts
+         curr_dir <- lift getCurrentDirectory
+         lib_dir  <- lift $ getLibraryDirectory (addOptions opts opts')
+         importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
+       Bad err ->
+         do putStrLnE $ "Command parse error: " ++ err
+
+-- | Commands that work on 'GFEnv'
+moreCommands = [
+  ("e",  emptyCommandInfo {
+     longname = "empty",
+     synopsis = "empty the environment (except the command history)",
+     exec = \ _ _ ->
+            do modify $ \ gfenv -> (emptyGFEnv (startOpts gfenv))
+                                     { history=history gfenv }
+               return void
+     }),
+  ("ph", emptyCommandInfo {
+     longname = "print_history",
+     synopsis = "print command history",
+     explanation = unlines [
+       "Prints the commands issued during the GF session.",
+       "The result is readable by the eh command.",
+       "The result can be used as a script when starting GF."
+       ],
+     examples = [
+      mkEx "ph | wf -file=foo.gfs  -- save the history into a file"
+      ],
+     exec = \ _ _ ->
+            fmap (fromString . unlines . reverse . drop 1 . history) get
+     }),
+  ("r",  emptyCommandInfo {
+     longname = "reload",
+     synopsis = "repeat the latest import command",
+     exec = \ _ _ ->
+       do gfenv0 <- get
+          let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
+          case imports of
+            (s,ws):_ -> do
+              putStrLnE $ "repeating latest import: " ++ s
+              import_ ws
+            _ -> do
+              putStrLnE $ "no import in history"
+          return void
+     })
+  ]
+
+
+printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
+
+fetchCommand :: GFEnv -> IO String
+fetchCommand gfenv = do
+  path <- getAppUserDataDirectory "gf_history"
+  let settings =
+        Haskeline.Settings {
+          Haskeline.complete = wordCompletion gfenv,
+          Haskeline.historyFile = Just path,
+          Haskeline.autoAddHistory = True
+        }
+  res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt gfenv))
+  case res of
+    Left  _        -> return ""
+    Right Nothing  -> return "q"
+    Right (Just s) -> return s
+
+importInEnv :: Options -> [FilePath] -> ShellM ()
+importInEnv opts files =
+  case files of
+    _ | flag optRetainResource opts ->
+          putStrLnE "Flag -retain is not supported in this shell"
+    [file] | takeExtensions file == ".pgf" -> importPGF file
+    [] -> return ()
+    _ -> do putStrLnE "Can only import one .pgf file"
+  where
+    importPGF file =
+      do gfenv <- get
+         case multigrammar gfenv of
+           Just _ -> putStrLnE "Discarding previous grammar"
+           _ -> return ()
+         pgf1 <- lift $ readPGF2 file
+         let gfenv' = gfenv { pgfenv = pgfEnv pgf1 }
+         when (verbAtLeast opts Normal) $
+           let langs = Map.keys . concretes $ gfenv'
+           in putStrLnE . unwords $ "\nLanguages:":langs
+         put gfenv'
+
+tryGetLine = do
+  res <- try getLine
+  case res of
+   Left (e :: SomeException) -> return "q"
+   Right l -> return l
+
+prompt env = abs ++ "> "
+  where
+    abs = maybe "" C.abstractName (multigrammar env)
+
+data GFEnv = GFEnv {
+    startOpts :: Options,
+  --grammar :: (), -- gfo grammar -retain
+  --retain :: (),  -- grammar was imported with -retain flag
+    pgfenv :: PGFEnv,
+    commandenv :: CommandEnv ShellM,
+    history    :: [String]
+  }
+
+emptyGFEnv opts = GFEnv opts {-() ()-} emptyPGFEnv emptyCommandEnv []
+
+emptyCommandEnv = mkCommandEnv allCommands
+multigrammar = pgf . pgfenv
+concretes = concs . pgfenv
+
+allCommands =
+  extend pgfCommands (helpCommand allCommands:moreCommands)
+  `Map.union` commonCommands
+
+instance HasPGFEnv ShellM where getPGFEnv = gets pgfenv
+
+-- ** Completion
+
+wordCompletion gfenv (left,right) = do
+  case wc_type (reverse left) of
+    CmplCmd pref
+      -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
+{-
+    CmplStr (Just (Command _ opts _)) s0
+      -> do mb_state0 <- try (evaluate (H.initState pgf (optLang opts) (optType opts)))
+            case mb_state0 of
+              Right state0 -> let (rprefix,rs) = break isSpace (reverse s0)
+                                  s            = reverse rs
+                                  prefix       = reverse rprefix
+                                  ws           = words s
+                              in case loop state0 ws of
+                                   Nothing    -> ret 0 []
+                                   Just state -> let compls = H.getCompletions state prefix
+                                                 in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls))
+              Left (_ :: SomeException) -> ret 0 []
+-}
+    CmplOpt (Just (Command n _ _)) pref
+      -> case Map.lookup n (commands cmdEnv) of
+           Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags   inf, isPrefixOf pref flg]
+                              opt_compls = [Haskeline.Completion ('-':opt)      ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt]
+                          ret (length pref+1)
+                              (flg_compls++opt_compls)
+           Nothing  -> ret (length pref) []
+    CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
+      -> Haskeline.completeFilename (left,right)
+
+    CmplIdent _ pref
+      -> case mb_pgf of
+           Just pgf -> ret (length pref)
+                           [Haskeline.simpleCompletion name 
+                            | name <- C.functions pgf,
+                              isPrefixOf pref name]
+           _ -> ret (length pref) []
+
+    _ -> ret 0 []
+  where
+    mb_pgf = multigrammar gfenv
+    cmdEnv = commandenv gfenv
+{-
+    optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts
+    optType opts = 
+      let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts
+      in case H.readType str of
+           Just ty -> ty
+           Nothing -> error ("Can't parse '"++str++"' as type")
+
+    loop ps []     = Just ps
+    loop ps (t:ts) = case H.nextState ps (H.simpleParseInput t) of
+                       Left  es -> Nothing
+                       Right ps -> loop ps ts
+-}
+    ret len xs  = return (drop len left,xs)
+
+
+data CompletionType
+  = CmplCmd                   Ident
+  | CmplStr   (Maybe Command) String
+  | CmplOpt   (Maybe Command) Ident
+  | CmplIdent (Maybe Command) Ident
+  deriving Show
+
+wc_type :: String -> CompletionType
+wc_type = cmd_name
+  where
+    cmd_name cs =
+      let cs1 = dropWhile isSpace cs
+      in go cs1 cs1
+      where
+        go x []       = CmplCmd x
+        go x (c:cs)
+          | isIdent c = go x cs
+          | otherwise = cmd x cs
+
+    cmd x []       = ret CmplIdent x "" 0
+    cmd _ ('|':cs) = cmd_name cs
+    cmd _ (';':cs) = cmd_name cs
+    cmd x ('"':cs) = str x cs cs
+    cmd x ('-':cs) = option x cs cs
+    cmd x (c  :cs)
+      | isIdent c  = ident x (c:cs) cs
+      | otherwise  = cmd x cs
+
+    option x y []       = ret CmplOpt x y 1
+    option x y ('=':cs) = optValue x y cs
+    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
+
+    ident x y []     = ret CmplIdent x y 0
+    ident x y (c:cs)
+      | isIdent c    = ident x y cs
+      | otherwise    = cmd x cs
+
+    str x y []          = ret CmplStr x y 1
+    str x y ('\"':cs)   = cmd x cs
+    str x y ('\\':c:cs) = str x y cs
+    str x y (c:cs)      = str x y cs
+
+    ret f x y d = f cmd y
+      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
+
+    isIdent c = c == '_' || c == '\'' || isAlphaNum c

src/compiler/GF/Main.hs

@@ -2,7 +2,10 @@
 {-# LANGUAGE CPP #-}
 module GF.Main where
 import GF.Compiler
-import GF.Interactive
+import qualified GF.Interactive as GFI1
+#ifdef C_RUNTIME
+import qualified GF.Interactive2 as GFI2
+#endif
 import GF.Data.ErrM
 import GF.Infra.Option
 import GF.Infra.UseIO
@@ -44,7 +47,17 @@ mainOpts opts files =
     case flag optMode opts of
       ModeVersion     -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
       ModeHelp        -> putStrLn helpMessage
-      ModeServer port -> mainServerGFI opts port files
+      ModeServer port -> GFI1.mainServerGFI opts port files
       ModeCompiler    -> mainGFC opts files
-      ModeInteractive -> mainGFI opts files
-      ModeRun         -> mainRunGFI opts files
+      ModeInteractive -> GFI1.mainGFI opts files
+      ModeRun         -> GFI1.mainRunGFI opts files
+#ifdef C_RUNTIME
+      ModeInteractive2 -> GFI2.mainGFI opts files
+      ModeRun2         -> GFI2.mainRunGFI opts files
+#else
+      ModeInteractive2 -> noCruntime
+      ModeRun2         -> noCruntime
+  where
+    noCruntime = do ePutStrLn "GF configured without C run-time support"
+                    exitFailure
+#endif

src/compiler/GF/Quiz.hs

@@ -18,8 +18,13 @@ module GF.Quiz (
   morphologyList
   ) where
 
-import PGF2
+import PGF
+--import PGF.Linearize
 import GF.Data.Operations
+--import GF.Infra.UseIO
+--import GF.Infra.Option
+--import PGF.Probabilistic
+
 import System.Random
 import Data.List (nub)
 
@@ -33,7 +38,7 @@ mkQuiz msg tts = do
   teachDialogue qas msg
 
 translationList :: 
-  Maybe Expr -> PGF -> Concr -> Concr -> Type -> Int -> IO [(String,[String])]
+  Maybe Expr -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])]
 translationList mex pgf ig og typ number = do
   gen <- newStdGen
   let ts   = take number $ case mex of
@@ -41,22 +46,19 @@ translationList mex pgf ig og typ number = do
                              Nothing -> generateRandom     gen pgf typ
   return $ map mkOne $ ts
  where
-   mkOne t = (norml (linearize ig t), 
+   mkOne t = (norml (linearize pgf ig t), 
               map norml (concatMap lins (homonyms t)))
-   homonyms t = 
-     case (parse ig typ . linearize ig) t of
-       ParseOk res -> map fst res
-       _           -> []
-   lins = nub . concatMap (map snd) . tabularLinearizeAll og
+   homonyms = parse pgf ig typ . linearize pgf ig
+   lins = nub . concatMap (map snd) . tabularLinearizes pgf og
 
 morphologyList :: 
-  Maybe Expr -> PGF -> Concr -> Type -> Int -> IO [(String,[String])]
+  Maybe Expr -> PGF -> Language -> Type -> Int -> IO [(String,[String])]
 morphologyList mex pgf ig typ number = do
   gen <- newStdGen
   let ts   = take (max 1 number) $ case mex of
                                      Just ex -> generateRandomFrom gen pgf ex
                                      Nothing -> generateRandom     gen pgf typ
-  let ss    = map (tabularLinearizeAll ig) ts
+  let ss    = map (tabularLinearizes pgf ig) ts
   let size  = length (head (head ss))
   let forms = take number $ randomRs (0,size-1) gen
   return [(snd (head pws0) +++ fst (pws0 !! i), ws) | 

src/compiler/GF/Server.hs

@@ -3,6 +3,7 @@
 module GF.Server(server) where
 import Data.List(partition,stripPrefix,isInfixOf)
 import qualified Data.Map as M
+import Control.Applicative -- for GHC<7.10
 import Control.Monad(when)
 import Control.Monad.State(StateT(..),get,gets,put)
 import Control.Monad.Error(ErrorT(..),Error(..))
@@ -33,7 +34,7 @@ import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
 --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
 import Network.CGI(handleErrors,liftIO)
 import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
-import Text.JSON(encode,showJSON,makeObj)
+import Text.JSON(JSValue(..),Result(..),valFromObj,encode,decode,showJSON,makeObj)
 --import System.IO.Silently(hCapture)
 import System.Process(readProcessWithExitCode)
 import System.Exit(ExitCode(..))
@@ -42,6 +43,7 @@ import GF.Infra.UseIO(readBinaryFile,writeBinaryFile,ePutStrLn)
 import GF.Infra.SIO(captureSIO)
 import GF.Data.Utilities(apSnd,mapSnd)
 import qualified PGFService as PS
+import qualified ExampleService as ES
 import Data.Version(showVersion)
 import Paths_gf(getDataDir,version)
 import GF.Infra.BuildInfo (buildInfo)
@@ -169,6 +171,7 @@ handle logLn documentroot state0 cache execute1 stateVar
                (_  ,_             ,".pgf") -> do --debug $ "PGF service: "++path
                                                  wrapCGI $ PS.cgiMain' cache path
                (dir,"grammars.cgi",_     ) -> grammarList dir (decoded qs)
+               (dir  ,"exb.fcgi"  ,_    ) -> wrapCGI $ ES.cgiMain' root dir (PS.pgfCache cache)
                _ -> serveStaticFile rpath path
              where path = translatePath rpath
            _ -> return $ resp400 upath
@@ -177,7 +180,7 @@ handle logLn documentroot state0 cache execute1 stateVar
 
     translatePath rpath = root</>rpath -- hmm, check for ".."
 
-    versionInfo c =
+    versionInfo (c1,c2) =
         html200 . unlines $
            "<!DOCTYPE html>":
            "<meta name = \"viewport\" content = \"width = device-width\">":
@@ -185,7 +188,8 @@ handle logLn documentroot state0 cache execute1 stateVar
            "":
            ("<h2>"++hdr++"</h2>"):
            (zipWith (++) ("<p>":repeat "<br>") buildinfo)++
-           sh "Run-time system" c
+           sh "Haskell run-time system" c1++
+           sh "C run-time system" c2
       where
         hdr:buildinfo = lines gf_version
         rel = makeRelative documentroot
@@ -280,13 +284,17 @@ handle logLn documentroot state0 cache execute1 stateVar
     skip_empty = filter (not.null.snd)
 
     jsonList = jsonList' return
-    jsonListLong = jsonList' (mapM addTime)
+    jsonListLong ext = jsonList' (mapM (addTime ext)) ext
     jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext)
 
-    addTime path =
+    addTime ext path =
         do t <- getModificationTime path
-           return $ makeObj ["path".=path,"time".=format t]
+           if ext==".json"
+             then addComment (time t) <$> liftIO (try $ getComment path)
+             else return . makeObj $ time t
       where
+        addComment t = makeObj . either (const t) (\c->t++["comment".=c])
+        time t = ["path".=path,"time".=format t]
         format = formatTime defaultTimeLocale rfc822DateFormat
 
     rm path | takeExtension path `elem` ok_to_delete =
@@ -328,6 +336,11 @@ handle logLn documentroot state0 cache execute1 stateVar
         do paths <- getDirectoryContents dir
            return [path | path<-paths, takeExtension path==ext]
 
+    getComment path =
+       do Ok (JSObject obj) <- decode <$> readFile path
+          Ok cmnt <- return (valFromObj "comment" obj)
+          return (cmnt::String)
+
 -- * Dynamic content
 
 jsonresult cwd dir cmd (ecode,stdout,stderr) files =

src/compiler/GF/Speech/CFGToFA.hs

@@ -14,6 +14,7 @@ import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import PGF.Internal
 import GF.Data.Utilities
 import GF.Grammar.CFG
 --import GF.Speech.PGFToCFG

src/compiler/GF/Speech/GSL.hs

@@ -7,12 +7,15 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.GSL (gslPrinter) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
+--import GF.Data.Utilities
 import GF.Grammar.CFG
 import GF.Speech.SRG
 import GF.Speech.RegExp
 import GF.Infra.Option
-import PGF2
+--import GF.Infra.Ident
+import PGF
 
 import Data.Char (toUpper,toLower)
 import Data.List (partition)
@@ -21,7 +24,7 @@ import GF.Text.Pretty
 width :: Int
 width = 75
 
-gslPrinter :: Options -> PGF -> Concr -> String
+gslPrinter :: Options -> PGF -> CId -> String
 gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
   where st = style { lineLength = width } 
 

src/compiler/GF/Speech/JSGF.hs

@@ -11,6 +11,7 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.JSGF (jsgfPrinter) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 --import GF.Data.Utilities
 import GF.Infra.Option
@@ -18,7 +19,7 @@ import GF.Grammar.CFG
 import GF.Speech.RegExp
 import GF.Speech.SISR
 import GF.Speech.SRG
-import PGF2
+import PGF
 
 import Data.Char
 import Data.List
@@ -30,8 +31,8 @@ width :: Int
 width = 75
 
 jsgfPrinter :: Options
-	        -> PGF 
-            -> Concr -> String
+	    -> PGF 
+            -> CId -> String
 jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
   where st = style { lineLength = width }
         sisr = flag optSISR opts

src/compiler/GF/Speech/PGFToCFG.hs

@@ -6,54 +6,60 @@
 ----------------------------------------------------------------------
 module GF.Speech.PGFToCFG (bnfPrinter, pgfToCFG) where
 
-import PGF2
-import PGF2.Internal
+import PGF(showCId)
+import PGF.Internal as PGF
+--import GF.Infra.Ident
 import GF.Grammar.CFG hiding (Symbol)
 
+import Data.Array.IArray as Array
+--import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
+--import Data.Maybe
 import Data.Set (Set)
 import qualified Data.Set as Set
 
-bnfPrinter :: PGF -> Concr -> String
+bnfPrinter :: PGF -> CId -> String
 bnfPrinter = toBNF id
 
-toBNF :: (CFG -> CFG) -> PGF -> Concr -> String
+toBNF :: (CFG -> CFG) -> PGF -> CId -> String
 toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
 
 type Profile = [Int]
 
-pgfToCFG :: PGF -> Concr -> CFG
-pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
+pgfToCFG :: PGF 
+          -> CId   -- ^ Concrete syntax name
+          -> CFG
+pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules)
   where
-    (_,start_cat,_) = unType (startCat pgf)
+    cnc = lookConcr pgf lang
 
     rules :: [(FId,Production)]
-    rules = [(fcat,prod) | fcat <- [0..concrTotalCats cnc],
-                           prod <- concrProductions cnc fcat]
+    rules = [(fcat,prod) | (fcat,set) <- IntMap.toList (PGF.productions cnc)
+                         , prod <- Set.toList set]
 
     fcatCats :: Map FId Cat
-    fcatCats = Map.fromList [(fc, c ++ "_" ++ show i) 
-                                 | (c,s,e,lbls) <- concrCategories cnc,
-                                   (fc,i) <- zip [s..e] [1..]]
+    fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) 
+                                 | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), 
+                                   (fc,i) <- zip (range (s,e)) [1..]]
 
     fcatCat :: FId -> Cat
     fcatCat c = Map.findWithDefault ("Unknown_" ++ show c) c fcatCats
 
-    fcatToCat :: FId -> Int -> Cat
+    fcatToCat :: FId -> LIndex -> Cat
     fcatToCat c l = fcatCat c ++ row
       where row = if catLinArity c == 1 then "" else "_" ++ show l
 
     -- gets the number of fields in the lincat for the given category
     catLinArity :: FId -> Int
-    catLinArity c = maximum (1:[length rhs | ((_,rhs), _) <- topdownRules c])
+    catLinArity c = maximum (1:[rangeSize (bounds rhs) | (CncFun _ rhs, _) <- topdownRules c])
 
     topdownRules cat = f cat []
       where
-        f cat rules = foldr g rules (concrProductions cnc cat)
+        f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc))
 	 
-        g (PApply funid args) rules = (concrFunction cnc funid,args) : rules
+        g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
         g (PCoerce cat)       rules = f cat rules
 
 
@@ -61,26 +67,26 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
     extCats = Set.fromList $ map ruleLhs startRules
 
     startRules :: [CFRule]
-    startRules = [Rule c [NonTerminal (fcatToCat fc r)] (CFRes 0) 
-                      | (c,s,e,lbls) <- concrCategories cnc,
-                        fc <- [s..e], not (isPredefFId fc),
+    startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) 
+                      | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), 
+                        fc <- range (s,e), not (isPredefFId fc),
                         r <- [0..catLinArity fc-1]]
 
     ruleToCFRule :: (FId,Production) -> [CFRule]
     ruleToCFRule (c,PApply funid args) = 
         [Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
-           | (l,seqid) <- zip [0..] rhs
-           , let row = concrSequence cnc seqid
+           | (l,seqid) <- Array.assocs rhs
+           , let row = sequences cnc ! seqid
            , not (containsLiterals row)]
       where
-        (f, rhs) = concrFunction cnc funid
+        CncFun f rhs = cncfuns cnc ! funid
 
-        mkRhs :: [Symbol] -> [CFSymbol]
-        mkRhs = concatMap symbolToCFSymbol
+        mkRhs :: Array DotPos Symbol -> [CFSymbol]
+        mkRhs = concatMap symbolToCFSymbol . Array.elems
 
-        containsLiterals :: [Symbol] -> Bool
-        containsLiterals row = not (null ([n | SymLit n _ <- row] ++
-                                          [n | SymVar n _ <- row]))
+        containsLiterals :: Array DotPos Symbol -> Bool
+        containsLiterals row = not (null ([n | SymLit n _ <- Array.elems row] ++
+                                          [n | SymVar n _ <- Array.elems row]))
 
         symbolToCFSymbol :: Symbol -> [CFSymbol]
         symbolToCFSymbol (SymCat n l)    = [let PArg _ fid = args!!n in NonTerminal (fcatToCat fid l)]
@@ -96,10 +102,10 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
         symbolToCFSymbol SymALL_CAPIT    = [Terminal "&|"]
         symbolToCFSymbol SymNE           = []
 
-        fixProfile :: [Symbol] -> Int -> Profile
+        fixProfile :: Array DotPos Symbol -> Int -> Profile
         fixProfile row i = [k | (k,j) <- nts, j == i]
             where
-              nts = zip [0..] [j | nt <- row, j <- getPos nt]
+              nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
               
               getPos (SymCat j _) = [j]
               getPos (SymLit j _) = [j]
@@ -107,10 +113,9 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
 
         profilesToTerm :: [Profile] -> CFTerm
         profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)
-            where Just (hypos,_,_) = fmap unType (functionType pgf f)
-                  argTypes = [cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]
+            where (argTypes,_) = catSkeleton $ lookType (abstract pgf) f
 
-        profileToTerm :: Fun -> Profile -> CFTerm
+        profileToTerm :: CId -> Profile -> CFTerm
         profileToTerm t [] = CFMeta t
         profileToTerm _ xs = CFRes (last xs) -- FIXME: unify
     ruleToCFRule (c,PCoerce c') =