remove RConcrete

Automatically upload release assets after building for release

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

@@ -14,7 +14,7 @@ jobs:
     strategy:
       matrix:
         os: [ubuntu-latest, macos-latest, windows-latest]
-        cabal: ["3.2"]
+        cabal: ["latest"]
         ghc:
           - "8.6.5"
           - "8.8.3"
@@ -33,7 +33,7 @@ jobs:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: actions/setup-haskell@v1.1.4
+    - uses: haskell/actions/setup@v1
       id: setup-haskell-cabal
       name: Setup Haskell
       with:
@@ -65,7 +65,7 @@ jobs:
     runs-on: ubuntu-latest
     strategy:
       matrix:
-        stack: ["2.3.3"]
+        stack: ["latest"]
         ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4"]
         # ghc: ["8.8.3"]
 
@@ -73,11 +73,12 @@ jobs:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: actions/setup-haskell@v1.1.4
+    - uses: haskell/actions/setup@v1
       name: Setup Haskell Stack
       with:
-        # ghc-version: ${{ matrix.ghc }}
-        stack-version: ${{ matrix.stack }}
+        ghc-version: ${{ matrix.ghc }}
+        stack-version: 'latest'
+        enable-stack: true
 
     - uses: actions/cache@v1
       name: Cache ~/.stack

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

@@ -2,7 +2,8 @@ name: Build Binary Packages
 
 on:
   workflow_dispatch:
-  release:
+  release: 
+    types: ["created"]
 
 jobs:
 
@@ -10,11 +11,13 @@ jobs:
 
   ubuntu:
     name: Build Ubuntu package
-    runs-on: ubuntu-18.04
-    # strategy:
-    #   matrix:
-    #     ghc: ["8.6.5"]
-    #     cabal: ["2.4"]
+    strategy:
+      matrix:
+        os:
+        - ubuntu-18.04
+        - ubuntu-20.04
+
+    runs-on: ${{ matrix.os }}
 
     steps:
     - uses: actions/checkout@v2
@@ -53,19 +56,33 @@ jobs:
     - name: Upload artifact
       uses: actions/upload-artifact@v2
       with:
-        name: gf-${{ github.sha }}-ubuntu
+        name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
         path: dist/gf_*.deb
         if-no-files-found: error
 
+    - name: Rename package for specific ubuntu version
+      run: |
+        mv dist/gf_*.deb dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
+
+    - uses: actions/upload-release-asset@v1.0.2
+      env:
+        GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+      with:
+        upload_url: ${{ github.event.release.upload_url }}
+        asset_path: dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
+        asset_name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
+        asset_content_type: application/octet-stream
+
 # ---
 
   macos:
     name: Build macOS package
-    runs-on: macos-10.15
     strategy:
       matrix:
         ghc: ["8.6.5"]
         cabal: ["2.4"]
+        os: ["macos-10.15"]
+    runs-on: ${{ matrix.os }}
 
     steps:
     - uses: actions/checkout@v2
@@ -92,19 +109,33 @@ jobs:
     - name: Upload artifact
       uses: actions/upload-artifact@v2
       with:
-        name: gf-${{ github.sha }}-macos
+        name: gf-${{ github.event.release.tag_name }}-macos
         path: dist/gf-*.pkg
         if-no-files-found: error
+    
+    - name: Rename package
+      run: |
+        mv dist/gf-*.pkg dist/gf-${{ github.event.release.tag_name }}-macos.pkg
+
+    - uses: actions/upload-release-asset@v1.0.2
+      env:
+        GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+      with:
+        upload_url: ${{ github.event.release.upload_url }}
+        asset_path: dist/gf-${{ github.event.release.tag_name }}-macos.pkg
+        asset_name: gf-${{ github.event.release.tag_name }}-macos.pkg
+        asset_content_type: application/octet-stream
 
 # ---
 
   windows:
     name: Build Windows package
-    runs-on: windows-2019
     strategy:
       matrix:
         ghc: ["8.6.5"]
         cabal: ["2.4"]
+        os: ["windows-2019"]
+    runs-on: ${{ matrix.os }}
 
     steps:
     - uses: actions/checkout@v2
@@ -136,16 +167,18 @@ jobs:
         cp /mingw64/bin/libpgf-0.dll /c/tmp-dist/c
         cp /mingw64/bin/libgu-0.dll /c/tmp-dist/c
 
+    # JAVA_HOME_8_X64 = C:\hostedtoolcache\windows\Java_Adopt_jdk\8.0.292-10\x64
     - name: Build Java bindings
       shell: msys2 {0}
       run: |
-        export PATH="${PATH}:/c/Program Files/Java/jdk8u275-b01/bin"
+        export JDKPATH=/c/hostedtoolcache/windows/Java_Adopt_jdk/8.0.292-10/x64
+        export PATH="${PATH}:${JDKPATH}/bin"
         cd src/runtime/java
         make \
-          JNI_INCLUDES="-I \"/c/Program Files/Java/jdk8u275-b01/include\" -I \"/c/Program Files/Java/jdk8u275-b01/include/win32\" -I \"/mingw64/include\" -D__int64=int64_t" \
+          JNI_INCLUDES="-I \"${JDKPATH}/include\" -I \"${JDKPATH}/include/win32\" -I \"/mingw64/include\" -D__int64=int64_t" \
           WINDOWS_LDFLAGS="-L\"/mingw64/lib\" -no-undefined"
         make install
-        cp .libs//msys-jpgf-0.dll /c/tmp-dist/java/jpgf.dll
+        cp .libs/msys-jpgf-0.dll /c/tmp-dist/java/jpgf.dll
         cp jpgf.jar /c/tmp-dist/java
 
     - name: Build Python bindings
@@ -157,7 +190,7 @@ jobs:
         cd src/runtime/python
         python setup.py build
         python setup.py install
-        cp /usr/lib/python3.8/site-packages/pgf* /c/tmp-dist/python
+        cp /usr/lib/python3.9/site-packages/pgf* /c/tmp-dist/python
 
     - name: Setup Haskell
       uses: actions/setup-haskell@v1
@@ -180,6 +213,18 @@ jobs:
     - name: Upload artifact
       uses: actions/upload-artifact@v2
       with:
-        name: gf-${{ github.sha }}-windows
+        name: gf-${{ github.event.release.tag_name }}-windows
         path: C:\tmp-dist\*
         if-no-files-found: error
+
+    - name: Create archive
+      run: |
+        Compress-Archive C:\tmp-dist C:\gf-${{ github.event.release.tag_name }}-windows.zip
+    - uses: actions/upload-release-asset@v1.0.2
+      env:
+        GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+      with:
+        upload_url: ${{ github.event.release.upload_url }}
+        asset_path: C:\gf-${{ github.event.release.tag_name }}-windows.zip
+        asset_name: gf-${{ github.event.release.tag_name }}-windows.zip
+        asset_content_type: application/zip

Makefile

@@ -1,31 +1,48 @@
-.PHONY: all build install doc clean gf html deb pkg bintar sdist
+.PHONY: all build install doc clean html deb pkg bintar sdist
 
 # This gets the numeric part of the version from the cabal file
 VERSION=$(shell sed -ne "s/^version: *\([0-9.]*\).*/\1/p" gf.cabal)
 
+# Check if stack is installed
+STACK=$(shell if hash stack 2>/dev/null; then echo "1"; else echo "0"; fi)
+
+# Check if cabal >= 2.4 is installed (with v1- and v2- commands)
+CABAL_NEW=$(shell if cabal v1-repl --help >/dev/null 2>&1 ; then echo "1"; else echo "0"; fi)
+
+ifeq ($(STACK),1)
+  CMD=stack
+else
+  CMD=cabal
+  ifeq ($(CABAL_NEW),1)
+    CMD_PFX=v1-
+  endif
+endif
+
 all: build
 
 dist/setup-config: gf.cabal Setup.hs WebSetup.hs
-	cabal configure
+ifneq ($(STACK),1)
+	cabal ${CMD_PFX}configure
+endif
 
 build: dist/setup-config
-	cabal build
+	${CMD} ${CMD_PFX}build
 
 install:
-	cabal copy
-	cabal register
+ifeq ($(STACK),1)
+	stack install
+else
+	cabal ${CMD_PFX}copy
+	cabal ${CMD_PFX}register
+endif
 
 doc:
-	cabal haddock
+	${CMD} ${CMD_PFX}haddock
 
 clean:
-	cabal clean
+	${CMD} ${CMD_PFX}clean
 	bash bin/clean_html
 
-gf:
-	cabal build rgl-none
-	strip dist/build/gf/gf
-
 html::
 	bash bin/update_html
 
@@ -35,7 +52,7 @@ html::
 deb:
 	dpkg-buildpackage -b -uc
 
-# Make an OS X Installer package
+# Make a macOS installer package
 pkg:
 	FMT=pkg bash bin/build-binary-dist.sh
 

debian/changelog

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

debian/rules

@@ -16,9 +16,9 @@ override_dh_shlibdeps:
 override_dh_auto_configure:
 	cd src/runtime/c && bash setup.sh configure --prefix=/usr
 	cd src/runtime/c && bash setup.sh build
-	cabal update
-	cabal install --only-dependencies
-	cabal configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c
+	cabal v1-update
+	cabal v1-install --only-dependencies
+	cabal v1-configure --prefix=/usr -fserver -fc-runtime --extra-lib-dirs=$(CURDIR)/src/runtime/c/.libs --extra-include-dirs=$(CURDIR)/src/runtime/c
 
 SET_LDL=LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
 
@@ -26,10 +26,10 @@ override_dh_auto_build:
 	cd src/runtime/python && EXTRA_INCLUDE_DIRS=$(CURDIR)/src/runtime/c EXTRA_LIB_DIRS=$(CURDIR)/src/runtime/c/.libs python setup.py build
 	cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr
 	echo $(SET_LDL)
-	-$(SET_LDL) cabal build
+	-$(SET_LDL) cabal v1-build
 
 override_dh_auto_install:
-	$(SET_LDL) cabal copy --destdir=$(CURDIR)/debian/gf
+	$(SET_LDL) cabal v1-copy --destdir=$(CURDIR)/debian/gf
 	cd src/runtime/c && bash setup.sh copy prefix=$(CURDIR)/debian/gf/usr
 	cd src/runtime/python && python setup.py install --prefix=$(CURDIR)/debian/gf/usr
 	cd src/runtime/java && make INSTALL_PATH=$(CURDIR)/debian/gf/usr install

doc/gf-developers-old-cabal.t2t

@@ -0,0 +1,201 @@
+GF Developer's Guide: Old installation instructions with Cabal
+
+
+This page contains the old installation instructions from the [Developer's Guide ../doc/gf-developers.html].
+We recommend Stack as a primary installation method, because it's easier for a Haskell beginner, and we want to keep the main instructions short.
+But if you are an experienced Haskeller and want to keep using Cabal, here are the old instructions using ``cabal install``.
+
+Note that some of these instructions may be outdated. Other parts may still be useful.
+
+== Compilation from source with Cabal ==
+
+The build system of GF is based on //Cabal//, which is part of the
+Haskell Platform, so no extra steps are needed to install it. In the simplest
+case, all you need to do to compile and install GF, after downloading the
+source code as described above, is
+
+```
+$ cabal install
+```
+
+This will automatically download any additional Haskell libraries needed to
+build GF. If this is the first time you use Cabal, you might need to run
+``cabal update`` first, to update the list of available libraries.
+
+If you want more control, the process can also be split up into the usual
+//configure//, //build// and //install// steps.
+
+=== Configure ===
+
+During the configuration phase Cabal will check that you have all
+necessary tools and libraries needed for GF. The configuration is
+started by the command:
+
+```
+$ cabal configure
+```
+
+If you don't see any error message from the above command then you
+have everything that is needed for GF. You can also add the option
+``-v`` to see more details about the configuration.
+
+You can use ``cabal configure --help`` to get a list of configuration options.
+
+=== Build ===
+
+The build phase does two things. First it builds the GF compiler from
+the Haskell source code and after that it builds the GF Resource Grammar
+Library using the already build compiler.  The simplest command is:
+
+```
+$ cabal build
+```
+
+Again you can add the option ``-v`` if you want to see more details.
+
+==== Parallel builds ====
+
+If you have Cabal>=1.20 you can enable parallel compilation by using
+
+```
+$ cabal build -j
+```
+
+or by putting a line
+```
+jobs: $ncpus
+```
+in your ``.cabal/config`` file. Cabal
+will pass this option to GHC when building the GF compiler, if you
+have GHC>=7.8.
+
+Cabal also passes ``-j`` to GF to enable parallel compilation of the
+Resource Grammar Library. This is done unconditionally to avoid
+causing problems for developers with Cabal<1.20. You can disable this
+by editing the last few lines in ``WebSetup.hs``.
+
+=== Install ===
+
+After you have compiled GF you need to install the executable and libraries
+to make the system usable.
+
+```
+$ cabal copy
+$ cabal register
+```
+
+This command installs the GF compiler for a single user, in the standard
+place used by Cabal.
+On Linux and Mac this could be ``$HOME/.cabal/bin``.
+On Mac it could also be ``$HOME/Library/Haskell/bin``.
+On Windows this is ``C:\Program Files\Haskell\bin``.
+
+The compiled GF Resource Grammar Library will be installed
+under the same prefix, e.g. in
+``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and
+in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows.
+
+If you want to install in some other place then use the ``--prefix``
+option during the configuration phase.
+
+=== Clean ===
+
+Sometimes you want to clean up the compilation and start again from clean
+sources. Use the clean command for this purpose:
+
+```
+$ cabal clean
+```
+
+
+%=== SDist ===
+%
+%You can use the command:
+%
+%% This does *NOT* include everything that is needed // TH 2012-08-06
+%```
+%$ cabal sdist
+%```
+%
+%to prepare archive with all source codes needed to compile GF.
+
+=== Known problems with Cabal ===
+
+Some versions of Cabal (at least version 1.16) seem to have a bug that can
+cause the following error:
+
+```
+Configuring gf-3.x...
+setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed
+```
+
+The exact cause of this problem is unclear, but it seems to happen
+during the configure phase if the same version of GF is already installed,
+so a workaround is to remove the existing installation with
+
+```
+ghc-pkg unregister gf
+```
+
+You can check with ``ghc-pkg list gf`` that it is gone.
+
+== Compilation with make ==
+
+If you feel more comfortable with Makefiles then there is a thin Makefile
+wrapper arround Cabal for you. If you just type:
+```
+$ make
+```
+the configuration phase will be run automatically if needed and after that
+the sources will be compiled.
+
+%% cabal build rgl-none does not work with recent versions of Cabal
+%If you don't want to compile the resource library
+%every time then you can use:
+%```
+%$ make gf
+%```
+
+For installation use:
+```
+$ make install
+```
+For cleaning:
+```
+$ make clean
+```
+%and to build source distribution archive run:
+%```
+%$ make sdist
+%```
+
+
+== Partial builds of RGL ==
+
+**NOTE**: The following doesn't work with recent versions of ``cabal``. //(This comment was left in 2015, so make your own conclusions.)//
+%% // TH 2015-06-22
+
+%Sometimes you just want to work on the GF compiler and don't want to
+%recompile the resource library after each change. In this case use
+%this extended command:
+
+%```
+%$ cabal build rgl-none
+%```
+
+The resource grammar library can be compiled in two modes: with present
+tense only and with all tenses. By default it is compiled with all
+tenses. If you want to use the library with only present tense you can
+compile it in this special mode with the command:
+
+```
+$ cabal build present
+```
+
+You could also control which languages you want to be recompiled by
+adding the option ``langs=list``. For example the following command
+will compile only the English and the Swedish language:
+
+```
+$ cabal build langs=Eng,Swe
+```

doc/gf-developers.t2t

@@ -1,6 +1,6 @@
 GF Developers Guide
 
-2018-07-26
+2021-07-15
 
 %!options(html): --toc
 
@@ -15,388 +15,287 @@ you are a GF user who just wants to download and install GF
 == Setting up your system for building GF ==
 
 To build GF from source you need to install some tools on your
-system: the //Haskell Platform//, //Git// and the //Haskeline library//.
+system: the Haskell build tool //Stack//, the version control software //Git// and the //Haskeline// library.
 
-**On Linux** the best option is to install the tools via the standard
-software distribution channels, i.e. by using the //Software Center//
-in Ubuntu or the corresponding tool in other popular Linux distributions.
-Or, from a Terminal window, the following command should be enough:
+%**On Linux** the best option is to install the tools via the standard
+%software distribution channels, i.e. by using the //Software Center//
+%in Ubuntu or the corresponding tool in other popular Linux distributions.
 
-- On Ubuntu: ``sudo apt-get install haskell-platform git libghc6-haskeline-dev``
-- On Fedora: ``sudo dnf install haskell-platform git ghc-haskeline-devel``
+%**On Mac OS and Windows**, the tools can be downloaded from their respective
+%web sites, as described below.
+
+=== Stack ===
+The primary installation method is via //Stack//.
+(You can also use Cabal, but we recommend Stack to those who are new to Haskell.)
+
+To install Stack:
+
+- **On Linux and Mac OS**, do either
+
+    ``$ curl -sSL https://get.haskellstack.org/ | sh``
+
+  or
+
+    ``$ wget -qO- https://get.haskellstack.org/ | sh``
 
 
-**On Mac OS and Windows**, the tools can be downloaded from their respective
-web sites, as described below.
+- **On other operating systems**, see the [installation guide https://docs.haskellstack.org/en/stable/install_and_upgrade].
 
-=== The Haskell Platform ===
 
-GF is written in Haskell, so first of all you need
-the //Haskell Platform//, e.g. version 8.0.2 or 7.10.3. Downloads
-and installation instructions are available from here:
+%If you already have Stack installed, upgrade it to the latest version by running: ``stack upgrade``
 
-    http://hackage.haskell.org/platform/
-
-Once you have installed the Haskell Platform, open a terminal
-(Command Prompt on Windows) and try to execute the following command:
-```
-$ ghc --version
-```
-This command should show you which version of GHC you have. If the installation
-of the Haskell Platform	 was successful you should see a message like:
-
-```
-The Glorious Glasgow Haskell Compilation System, version 8.0.2
-```
-
-Other required tools included in the Haskell Platform are
-[Cabal http://www.haskell.org/cabal/],
-[Alex http://www.haskell.org/alex/]
-and
-[Happy http://www.haskell.org/happy/].
 
 === Git ===
 
-To get the GF source code, you also need //Git//.
-//Git// is a distributed version control system, see
-https://git-scm.com/downloads for more information.
+To get the GF source code, you also need //Git//, a distributed version control system.
 
-=== The haskeline library ===
+- **On Linux**, the best option is to install the tools via the standard
+software distribution channels:
+
+  - On Ubuntu: ``sudo apt-get install git-all``
+  - On Fedora: ``sudo dnf install git-all``
+
+
+- **On other operating systems**, see
+https://git-scm.com/book/en/v2/Getting-Started-Installing-Git for installation.
+
+
+
+=== Haskeline ===
 
 GF uses //haskeline// to enable command line editing in the GF shell.
-This should work automatically on Mac OS and Windows, but on Linux one
-extra step is needed to make sure the C libraries (terminfo)
-required by //haskeline// are installed.  Here is one way to do this:
 
-- On Ubuntu: ``sudo apt-get install libghc-haskeline-dev``
-- On Fedora: ``sudo dnf install ghc-haskeline-devel``
+- **On Mac OS and Windows**, this should work automatically.
+
+- **On Linux**, an extra step is needed to make sure the C libraries (terminfo)
+required by //haskeline// are installed:
+
+  - On Ubuntu: ``sudo apt-get install libghc-haskeline-dev``
+  - On Fedora: ``sudo dnf install ghc-haskeline-devel``
 
 
-== Getting the source ==
+== Getting the source ==[getting-source]
 
-Once you have all tools in place you can get the GF source code. If you
-just want to compile and use GF then it is enough to have read-only
-access. It is also possible to make changes in the source code but if you
-want these changes to be applied back to the main source repository you will
-have to send the changes to us.  If you plan to work continuously on
-GF then you should consider getting read-write access.
+Once you have all tools in place you can get the GF source code from
+[GitHub https://github.com/GrammaticalFramework/]:
 
-=== Read-only access ===
+- https://github.com/GrammaticalFramework/gf-core for the GF compiler
+- https://github.com/GrammaticalFramework/gf-rgl for the Resource Grammar Library
 
-==== Getting a fresh copy for read-only access ====
 
-Anyone can get the latest development version of GF by running:
+=== Read-only access: clone the main repository ===
+
+If you only want to compile and use GF, you can just clone the repositories as follows:
 
 ```
-$ git clone https://github.com/GrammaticalFramework/gf-core.git
-$ git clone https://github.com/GrammaticalFramework/gf-rgl.git
+  $ git clone https://github.com/GrammaticalFramework/gf-core.git
+  $ git clone https://github.com/GrammaticalFramework/gf-rgl.git
 ```
 
-This will create directories ``gf-core`` and ``gf-rgl`` in the current directory.
-
-
-==== Updating your copy ====
-
-To get all new patches from each repo:
-```
-$ git pull
-```
-This can be done anywhere in your local repository.
-
-
-==== Recording local changes ====[record]
-
-Since every copy is a repository, you can have local version control
-of your changes.
-
-If you have added files, you first need to tell your local repository to
-keep them under revision control:
+To get new updates, run the following anywhere in your local copy of the repository:
 
 ```
-$ git add file1 file2 ...
+  $ git pull
 ```
 
-To record changes, use:
+=== Contribute your changes: fork the main repository ===
+
+If you want the possibility to contribute your changes,
+you should create your own fork, do your changes there,
+and then send a pull request to the main repository.
+
++ **Creating and cloning a fork  —**
+See GitHub documentation for instructions how to [create your own fork https://docs.github.com/en/get-started/quickstart/fork-a-repo]
+of the repository. Once you've done it, clone the fork to your local computer.
 
 ```
-$ git commit file1 file2 ...
+  $ git clone https://github.com/<YOUR_USERNAME>/gf-core.git
 ```
 
-This creates a patch against the previous version and stores it in your
-local repository. You can record any number of changes before
-pushing them to the main repo. In fact, you don't have to push them at
-all if you want to keep the changes only in your local repo.
-
-Instead of enumerating all modified files on the command line,
-you can use the flag ``-a`` to automatically record //all// modified
-files. You still need to use ``git add`` to add new files.
-
-
-=== Read-write access ===
-
-If you are a member of the GF project on GitHub, you can push your
-changes directly to the GF git repository on GitHub.
++ **Updating your copy —**
+Once you have cloned your fork, you need to set up the main repository as a remote:
 
 ```
-$ git push
+  $ git remote add upstream https://github.com/GrammaticalFramework/gf-core.git
 ```
 
-It is also possible for anyone else to contribute by
+Then you can get the latest updates by running the following:
 
-- creating a fork of the GF repository on GitHub,
-- working with local clone of the fork (obtained with ``git clone``),
-- pushing changes to the fork,
-- and finally sending a pull request.
+```
+  $ git pull upstream master
+```
+
++ **Recording local changes —**
+See Git tutorial on how to [record and push your changes https://git-scm.com/book/en/v2/Git-Basics-Recording-Changes-to-the-Repository] to your fork.
+
++ **Pull request —**
+When you want to contribute your changes to the main gf-core repository,
+[create a pull request https://docs.github.com/en/github/collaborating-with-pull-requests/proposing-changes-to-your-work-with-pull-requests/creating-a-pull-request]
+from your fork.
 
 
 
-== Compilation from source with Cabal ==
+If you want to contribute to the RGL as well, do the same process for the RGL repository.
 
-The build system of GF is based on //Cabal//, which is part of the
-Haskell Platform, so no extra steps are needed to install it. In the simplest
-case, all you need to do to compile and install GF, after downloading the
-source code as described above, is
+
+== Compilation from source ==
+
+By now you should have installed Stack and Haskeline, and cloned the Git repository on your own computer, in a directory called ``gf-core``.
+
+=== Primary recommendation: use Stack ===
+
+Open a terminal, go to the top directory (``gf-core``), and type the following command.
+
+```
+$ stack install
+```
+
+It will install GF and all necessary tools and libraries to do that.
+
+
+=== Alternative: use Cabal ===
+You can also install GF using Cabal, if you prefer Cabal to Stack. In that case, you may need to install some prerequisites yourself.
+
+The actual installation process is similar to Stack: open a terminal, go to the top directory (``gf-core``), and type the following command.
 
 ```
 $ cabal install
 ```
 
-This will automatically download any additional Haskell libraries needed to
-build GF. If this is the first time you use Cabal, you might need to run
-``cabal update`` first, to update the list of available libraries.
+//The old (potentially outdated) instructions for Cabal are moved to a [separate page ../doc/gf-developers-old-cabal.html]. If you run into trouble with ``cabal install``, you may want to take a look.//
 
-If you want more control, the process can also be split up into the usual
-//configure//, //build// and //install// steps.
+== Compiling GF with C runtime system support ==
 
-=== Configure ===
-
-During the configuration phase Cabal will check that you have all
-necessary tools and libraries needed for GF. The configuration is
-started by the command:
-
-```
-$ cabal configure
-```
-
-If you don't see any error message from the above command then you
-have everything that is needed for GF. You can also add the option
-``-v`` to see more details about the configuration.
-
-You can use ``cabal configure --help`` to get a list of configuration options.
-
-=== Build ===
-
-The build phase does two things. First it builds the GF compiler from
-the Haskell source code and after that it builds the GF Resource Grammar
-Library using the already build compiler.  The simplest command is:
-
-```
-$ cabal build
-```
-
-Again you can add the option ``-v`` if you want to see more details.
-
-==== Parallel builds ====
-
-If you have Cabal>=1.20 you can enable parallel compilation by using
-
-```
-$ cabal build -j
-```
-
-or by putting a line
-```
-jobs: $ncpus
-```
-in your ``.cabal/config`` file. Cabal
-will pass this option to GHC when building the GF compiler, if you
-have GHC>=7.8.
-
-Cabal also passes ``-j`` to GF to enable parallel compilation of the
-Resource Grammar Library. This is done unconditionally to avoid
-causing problems for developers with Cabal<1.20. You can disable this
-by editing the last few lines in ``WebSetup.hs``.
-
-
-==== Partial builds ====
-
-**NOTE**: The following doesn't work with recent versions of ``cabal``.
-%% // TH 2015-06-22
-
-Sometimes you just want to work on the GF compiler and don't want to
-recompile the resource library after each change. In this case use
-this extended command:
-
-```
-$ cabal build rgl-none
-```
-
-The resource library could also be compiled in two modes: with present
-tense only and with all tenses. By default it is compiled with all
-tenses. If you want to use the library with only present tense you can
-compile it in this special mode with the command:
-
-```
-$ cabal build present
-```
-
-You could also control which languages you want to be recompiled by
-adding the option ``langs=list``. For example the following command
-will compile only the English and the Swedish language:
-
-```
-$ cabal build langs=Eng,Swe
-```
-
-=== Install ===
-
-After you have compiled GF you need to install the executable and libraries
-to make the system usable.
-
-```
-$ cabal copy
-$ cabal register
-```
-
-This command installs the GF compiler for a single user, in the standard
-place used by Cabal.
-On Linux and Mac this could be ``$HOME/.cabal/bin``.
-On Mac it could also be ``$HOME/Library/Haskell/bin``.
-On Windows this is ``C:\Program Files\Haskell\bin``.
-
-The compiled GF Resource Grammar Library will be installed
-under the same prefix, e.g. in
-``$HOME/.cabal/share/gf-3.3.3/lib`` on Linux and
-in ``C:\Program Files\Haskell\gf-3.3.3\lib`` on Windows.
-
-If you want to install in some other place then use the ``--prefix``
-option during the configuration phase.
-
-=== Clean ===
-
-Sometimes you want to clean up the compilation and start again from clean
-sources. Use the clean command for this purpose:
-
-```
-$ cabal clean
-```
-
-
-%=== SDist ===
-%
-%You can use the command:
-%
-%% This does *NOT* include everything that is needed // TH 2012-08-06
-%```
-%$ cabal sdist
-%```
-%
-%to prepare archive with all source codes needed to compile GF.
-
-=== Known problems with Cabal ===
-
-Some versions of Cabal (at least version 1.16) seem to have a bug that can
-cause the following error:
-
-```
-Configuring gf-3.x...
-setup: Distribution/Simple/PackageIndex.hs:124:8-13: Assertion failed
-```
-
-The exact cause of this problem is unclear, but it seems to happen
-during the configure phase if the same version of GF is already installed,
-so a workaround is to remove the existing installation with
-
-```
-ghc-pkg unregister gf
-```
-
-You can check with ``ghc-pkg list gf`` that it is gone.
-
-== Compilation with make ==
-
-If you feel more comfortable with Makefiles then there is a thin Makefile
-wrapper arround Cabal for you. If you just type:
-```
-$ make
-```
-the configuration phase will be run automatically if needed and after that
-the sources will be compiled.
-
-%% cabal build rgl-none does not work with recent versions of Cabal
-%If you don't want to compile the resource library
-%every time then you can use:
-%```
-%$ make gf
-%```
-
-For installation use:
-```
-$ make install
-```
-For cleaning:
-```
-$ make clean
-```
-%and to build source distribution archive run:
-%```
-%$ make sdist
-%```
-
-== Compiling GF with C run-time system support ==
-
-The C run-time system is a separate implementation of the PGF run-time services.
+The C runtime system is a separate implementation of the PGF runtime services.
 It makes it possible to work with very large, ambiguous grammars, using
-probabilistic models to obtain probable parses. The C run-time system might
-also be easier to use than the Haskell run-time system on certain platforms,
+probabilistic models to obtain probable parses. The C runtime system might
+also be easier to use than the Haskell runtime system on certain platforms,
 e.g. Android and iOS.
 
-To install the C run-time system, go to the ``src/runtime/c`` directory
-%and follow the instructions in the ``INSTALL`` file.
-and use the ``install.sh`` script:
-```
-bash setup.sh configure
-bash setup.sh build
-bash setup.sh install
-```
-This will install
-the C header files and libraries need to write C programs that use PGF grammars.
-Some example C programs are included in the ``utils`` subdirectory, e.g.
-``pgf-translate.c``.
+To install the C runtime system, go to the ``src/runtime/c`` directory.
 
-When the C run-time system is installed, you can install GF with C run-time
-support by doing
+- **On Linux and Mac OS —**
+  You should have autoconf, automake, libtool and make.
+  If you are missing some of them, follow the
+  instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file.
+
+  Once you have the required libraries, the easiest way to install the C runtime is to use the ``install.sh`` script. Just type
+
+  ``$ bash install.sh``
+
+  This will install the C header files and libraries need to write C programs
+  that use PGF grammars.
+
+%  If this doesn't work for you, follow the manual instructions in the [INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system.
+
+- **On other operating systems —** Follow the instructions in the
+[INSTALL https://github.com/GrammaticalFramework/gf-core/blob/master/src/runtime/c/INSTALL] file under your operating system.
+
+
+
+Depending on what you want to do with the C runtime, you can follow one or more of the following steps.
+
+=== Use the C runtime from another programming language ===[bindings]
+
+% **If you just want to use the C runtime from Python, Java, or Haskell, you don't need to change your GF installation.**
+
+- **What —**
+This is the most common use case for the C runtime: compile
+your GF grammars into PGF with the standard GF executable,
+and manipulate the PGFs from another programming language,
+using the bindings to the C runtime.
+
+
+- **How —**
+The Python, Java and Haskell bindings are found in the
+``src/runtime/{python,java,haskell-bind}`` directories,
+respecively. Compile them by following the instructions
+in the ``INSTALL`` or ``README`` files in those directories.
+
+The Python library can also be installed from PyPI using ``pip install pgf``.
+
+
+//If you are on Mac and get an error about ``clang`` version, you can try some of [these solutions https://stackoverflow.com/questions/63972113/big-sur-clang-invalid-version-error-due-to-macosx-deployment-target]—but be careful before removing any existing installations.//
+
+
+=== Use GF shell with C runtime support ===
+
+- **What —**
+If you want to use the GF shell with C runtime functionalities, then you need to (re)compile GF with special flags.
+
+The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use
+the C run-time system instead of the Haskell run-time system.
+Only limited functionality is available when running the shell in these
+modes (use the ``help`` command in the shell for details).
+
+(Re)compiling your GF with these flags will also give you
+Haskell bindings to the C runtime, as a library called ``PGF2``,
+but if you want Python or Java bindings, you need to do [the previous step #bindings].
+
+% ``PGF2``: a module to import in Haskell programs, providing a binding to the C run-time system.
+
+- **How —**
+If you use cabal, run the following command:
 
 ```
-cabal install -fserver -fc-runtime
+cabal install -fc-runtime
 ```
-from the top directory. This give you three new things:
 
-- ``PGF2``: a module to import in Haskell programs, providing a binding to
-   the C run-time system.
+from the top directory (``gf-core``).
 
-- The GF shell can be started with ``gf -cshell`` or ``gf -crun`` to use
-  the C run-time system instead of the Haskell run-time system.
-  Only limited functionality is available when running the shell in these
-  modes (use the ``help`` command in the shell for details).
+If you use stack, uncomment the following lines in the ``stack.yaml`` file:
 
-- ``gf -server`` mode is extended with new requests to call the C run-time
-   system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``.
+```
+flags:
+   gf:
+     c-runtime: true
+extra-lib-dirs:
+   - /usr/local/lib
+```
+and then run ``stack install`` from the top directory (``gf-core``).
 
 
-=== Python and Java bindings ===
+//If you get an "``error while loading shared libraries``" when trying to run GF with C runtime, remember to declare your ``LD_LIBRARY_PATH``.//
+//Add ``export LD_LIBRARY_PATH="/usr/local/lib"`` to either your ``.bashrc`` or ``.profile``. You should now be able to start GF with C runtime.//
+
+
+=== Use GF server mode with C runtime ===
+
+- **What —**
+With this feature, ``gf -server`` mode is extended with new requests to call the C run-time
+system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``.
+
+- **How —**
+If you use cabal, run the following command:
+
+```
+cabal install -fc-runtime -fserver
+```
+from the top directory.
+
+If you use stack, add the following lines in the ``stack.yaml`` file:
+
+```
+flags:
+   gf:
+     c-runtime: true
+     server: true
+extra-lib-dirs:
+   - /usr/local/lib
+```
+
+and then run ``stack install``, also from the top directory.
 
-The C run-time system can also be used from Python and Java. Python and Java
-bindings are found in the ``src/runtime/python`` and ``src/runtime/java``
-directories, respecively. Compile them by following the instructions in
-the ``INSTALL`` files in those directories.
 
-The Python library can also be installed from PyPI using `pip install pgf`.
 
 == Compilation of RGL ==
 
 As of 2018-07-26, the RGL is distributed separately from the GF compiler and runtimes.
 
+To get the source, follow the previous instructions on [how to clone a repository with Git #getting-source].
+
+After cloning the RGL, you should have a directory named ``gf-rgl`` on your computer.
+
 === Simple ===
 To install the RGL, you can use the following commands from within the ``gf-rgl`` repository:
 ```
@@ -418,103 +317,68 @@ If you do not have Haskell installed, you can use the simple build script ``Setu
 
 == Creating binary distribution packages ==
 
-=== Creating .deb packages for Ubuntu ===
+The binaries are generated with Github Actions. More details can be viewed here:
 
-This was tested on Ubuntu 14.04 for the release of GF 3.6, and the
-resulting ``.deb`` packages appears to work on Ubuntu 12.04, 13.10 and 14.04.
-For the release of GF 3.7, we generated ``.deb`` packages on Ubuntu 15.04 and
-tested them on Ubuntu 12.04 and 14.04.
+https://github.com/GrammaticalFramework/gf-core/actions/workflows/build-binary-packages.yml
 
-Under Ubuntu, Haskell executables are statically linked against other Haskell
-libraries, so the .deb packages are fairly self-contained.
 
-==== Preparations ====
+== Running the test suite ==
+
+The GF test suite is run with one of the following commands from the top directory:
 
 ```
-sudo apt-get install dpkg-dev debhelper
+  $ cabal test
 ```
 
-==== Creating the package ====
-
-Make sure the ``debian/changelog`` starts with an entry that describes the
-version you are building. Then run
+or
 
 ```
-make deb
+  $ stack test
 ```
 
-If get error messages about missing dependencies
-(e.g. ``autoconf``, ``automake``, ``libtool-bin``, ``python-dev``,
-``java-sdk``, ``txt2tags``)
-use ``apt-get intall`` to install them, then try again.
-
-
-=== Creating OS X Installer packages ===
-
-Run
-
-```
-make pkg
-```
-
-=== Creating binary tar distributions ===
-
-Run
-
-```
-make bintar
-```
-
-=== Creating .rpm packages for Fedora ===
-
-This is possible, but the procedure has not been automated.
-It involves using the cabal-rpm tool,
-
-```
-sudo dnf install cabal-rpm
-```
-
-and following the Fedora guide
-[How to create an RPM package http://fedoraproject.org/wiki/How_to_create_an_RPM_package].
-
-Under Fedora, Haskell executables are dynamically linked against other Haskell
-libraries, so ``.rpm`` packages for all Haskell libraries that GF depends on
-are required. Most of them are already available in the Fedora distribution,
-but a few of them might have to be built and distributed along with
-the GF ``.rpm`` package.
-When building ``.rpm`` packages for GF 3.4, we also had to build ``.rpm``s for
-``fst`` and ``httpd-shed``.
-
-== Running the testsuite ==
-
-**NOTE:** The test suite has not been maintained recently, so expect many
-tests to fail.
-%% // TH 2012-08-06
-
-GF has testsuite. It is run with the following command:
-```
-$ cabal test
-```
 The testsuite architecture for GF is very simple but still very flexible.
 GF by itself is an interpreter and could execute commands in batch mode.
 This is everything that we need to organize a testsuite. The root of the
-testsuite is the testsuite/ directory. It contains subdirectories which
-themself contain GF batch files (with extension .gfs). The above command
-searches the subdirectories of the testsuite/ directory for files with extension
-.gfs and when it finds one it is executed with the GF interpreter.
-The output of the script is stored in file with extension .out and is compared
-with the content of the corresponding file with extension .gold, if there is one.
-If the contents are identical the command reports that the test was passed successfully.
-Otherwise the test had failed.
+testsuite is the ``testsuite/`` directory. It contains subdirectories
+which themselves contain GF batch files (with extension ``.gfs``).
+The above command searches the subdirectories of the ``testsuite/`` directory
+for files with extension ``.gfs`` and when it finds one, it is executed with
+the GF interpreter. The output of the script is stored in file with extension ``.out``
+and is compared with the content of the corresponding file with extension ``.gold``, if there is one.
 
-Every time when you make some changes to GF that have to be tested, instead of
-writing the commands by hand in the GF shell, add them to one .gfs file in the testsuite
-and run the test. In this way you can use the same test later and we will be sure
-that we will not incidentaly break your code later.
+Every time when you make some changes to GF that have to be tested,
+instead of writing the commands by hand in the GF shell, add them to one ``.gfs``
+file in the testsuite subdirectory where its ``.gf`` file resides and run the test.
+In this way you can use the same test later and we will be sure that we will not
+accidentally break your code later.
+
+**Test Outcome - Passed:** If the contents of the files with the ``.out`` extension
+are identical to their correspondingly-named files with the extension ``.gold``,
+the command will report that the tests passed successfully, e.g.
 
-If you don't want to run the whole testsuite you can write the path to the subdirectory
-in which you are interested. For example:
 ```
-$ cabal test testsuite/compiler
+ Running 1 test suites...
+ Test suite gf-tests: RUNNING...
+ Test suite gf-tests: PASS
+ 1 of 1 test suites (1 of 1 test cases) passed.
 ```
-will run only the testsuite for the compiler.
+
+**Test Outcome - Failed:**  If there is a contents mismatch between the files
+with the ``.out`` extension and their corresponding files with the extension ``.gold``,
+the test diagnostics will show a fail and the areas that failed. e.g.
+
+```
+  testsuite/compiler/compute/Records.gfs: OK
+  testsuite/compiler/compute/Variants.gfs: FAIL
+  testsuite/compiler/params/params.gfs: OK
+  Test suite gf-tests: FAIL
+  0 of 1 test suites (0 of 1 test cases) passed.
+```
+
+The fail results overview is available in gf-tests.html which shows 4 columns:
+
++ __Results__ - only areas that fail will appear. (Note: There are 3 failures in the gf-tests.html which are labelled as (expected). These failures should be ignored.)
++ __Input__ - which is the test written in the .gfs file
++ __Gold__ - the expected output from running the test set out in the .gfs file. This column refers to the contents from the .gold extension files.
++ __Output__ - This column refers to the contents from the .out extension files which are generated as test output.
+After fixing the areas which fail, rerun the test command. Repeat the entire process of fix-and-test until the test suite passes before  submitting a pull request to include your changes.

doc/gf-editor-modes.t2t

@@ -15,6 +15,12 @@ instructions inside.
 ==Atom==
 [language-gf https://atom.io/packages/language-gf], by John J. Camilleri
 
+==Visual Studio Code==
+
+[Grammatical Framework Language Server https://marketplace.visualstudio.com/items?itemName=anka-213.gf-vscode] by Andreas Källberg.
+
+This provides syntax highlighting and a client for the Grammatical Framework language server. Follow the installation instructions in the link.
+
 ==Eclipse==
 
 [GF Eclipse Plugin https://github.com/GrammaticalFramework/gf-eclipse-plugin/], by John J. Camilleri

download/index-3.11.md

@@ -1,8 +1,9 @@
 ---
 title: Grammatical Framework Download and Installation
-...
+date: 25 July 2021
+---
 
-**GF 3.11** was released on ... December 2020.
+**GF 3.11** was released on 25 July 2021.
 
 What's new? See the [release notes](release-3.11.html).
 
@@ -24,22 +25,25 @@ Binary packages are available for Debian/Ubuntu, macOS, and Windows and include:
 
 Unlike in previous versions, the binaries **do not** include the RGL.
 
-[Binary packages on GitHub](https://github.com/GrammaticalFramework/gf-core/releases/tag/RELEASE-3.11)
+[Binary packages on GitHub](https://github.com/GrammaticalFramework/gf-core/releases/tag/3.11)
 
 #### Debian/Ubuntu
 
+There are two versions: `gf-3.11-ubuntu-18.04.deb` for Ubuntu 18.04 (Cosmic), and `gf-3.11-ubuntu-20.04.deb` for Ubuntu 20.04 (Focal).
+
 To install the package use:
+
 ```
-sudo dpkg -i gf_3.11.deb
+sudo apt-get install ./gf-3.11-ubuntu-*.deb
 ```
 
-The Ubuntu `.deb` packages should work on Ubuntu 16.04, 18.04 and similar Linux distributions.
+<!-- The Ubuntu `.deb` packages should work on Ubuntu 16.04, 18.04 and similar Linux distributions. -->
 
 #### macOS
 
 To install the package, just double-click it and follow the installer instructions.
 
-The packages should work on at least 10.13 (High Sierra) and 10.14 (Mojave).
+The packages should work on at least Catalina and Big Sur.
 
 #### Windows
 
@@ -49,7 +53,7 @@ You will probably need to update the `PATH` environment variable to include your
 
 For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10).
 
-## Installing the latest Hackage release (macOS, Linux, and WSL2 on Windows)
+<!--## Installing the latest Hackage release (macOS, Linux, and WSL2 on Windows)
 
 [GF is on Hackage](http://hackage.haskell.org/package/gf), so under
 normal circumstances the procedure is fairly simple:
@@ -89,7 +93,7 @@ Here is one way to do this:
 **GHC version**
 
 The GF source code has been updated to compile with GHC versions 7.10 through to 8.8.
-
+-->
 ## Installing from the latest developer source code
 
 If you haven't already, clone the repository with:
@@ -116,7 +120,7 @@ or, if you're a Stack user:
 stack install
 ```
 
-The above notes for installing from source apply also in these cases.
+<!--The above notes for installing from source apply also in these cases.-->
 For more info on working with the GF source code, see the
 [GF Developers Guide](../doc/gf-developers.html).
 

download/index.html

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

download/release-3.11.md

@@ -1,7 +1,7 @@
 ---
 title: GF 3.11 Release Notes
-date: ... December 2020
-...
+date: 25 July 2021
+---
 
 ## Installation
 
@@ -12,24 +12,27 @@ See the [download page](index-3.11.html).
 From this release, the binary GF core packages do not contain the RGL.
 The RGL's release cycle is now completely separate from GF's. See [RGL releases](https://github.com/GrammaticalFramework/gf-rgl/releases).
 
-Over 400 changes have been pushed to GF core
+Over 500 changes have been pushed to GF core
 since the release of GF 3.10 in December 2018.
 
 ## General
 
 - Make the test suite work again.
 - Compatibility with new versions of GHC, including multiple Stack files for the different versions.
-- Updates to build scripts and CI.
-- Bug fixes.
+- Support for newer version of Ubuntu 20.04 in the precompiled binaries.
+- Updates to build scripts and CI workflows.
+- Bug fixes and code cleanup.
 
 ## GF compiler and run-time library
 
-- Huge improvements in time & space requirements for grammar compilation (pending [#87](https://github.com/GrammaticalFramework/gf-core/pull/87)).
 - Add CoNLL output to `visualize_tree` shell command.
 - Add canonical GF as output format in the compiler.
 - Add PGF JSON as output format in the compiler.
 - Deprecate JavaScript runtime in favour of updated [TypeScript runtime](https://github.com/GrammaticalFramework/gf-typescript).
+- Improvements in time & space requirements when compiling certain grammars.
 - Improvements to Haskell export.
+- Improvements to the GF shell.
+- Improvements to canonical GF compilation.
 - Improvements to the C runtime.
 - Improvements to `gf -server` mode.
 - Clearer compiler error messages.

gf.cabal

@@ -1,17 +1,16 @@
 name: gf
-version: 3.10.4-git
+version: 3.11.0-git
 
-cabal-version: >= 1.22
+cabal-version: 1.22
 build-type: Custom
 license: OtherLicense
 license-file: LICENSE
 category: Natural Language Processing, Compiler
 synopsis: Grammatical Framework
 description: GF, Grammatical Framework, is a programming language for multilingual grammar applications
-homepage: http://www.grammaticalframework.org/
+homepage: https://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-maintainer: Thomas Hallgren
-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
 
 data-dir: src
 extra-source-files: WebSetup.hs
@@ -42,39 +41,34 @@ data-files:
 
 custom-setup
   setup-depends:
-    base,
-    Cabal >=1.22.0.0,
-    directory,
-    filepath,
-    process >=1.0.1.1
+    base >= 4.9.1 && < 4.15,
+    Cabal >= 1.22.0.0,
+    directory >= 1.3.0 && < 1.4,
+    filepath >= 1.4.1 && < 1.5,
+    process >= 1.0.1.1 && < 1.7
 
 source-repository head
-  type:     git
+  type: git
   location: https://github.com/GrammaticalFramework/gf-core.git
 
 flag interrupt
   Description: Enable Ctrl+Break in the shell
-  Default:     True
+  Default: True
 
 flag server
   Description: Include --server mode
-  Default:     True
+  Default: True
 
 flag network-uri
    description: Get Network.URI from the network-uri package
    default: True
 
---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
+executable gf
+  hs-source-dirs: src/programs, src/compiler
+  main-is: gf-main.hs
   default-language:    Haskell2010
-  build-depends: base >= 4.6 && <5,
+  build-depends: pgf2,
+                 base >= 4.6 && <5,
                  array,
                  containers,
                  bytestring,
@@ -83,81 +77,18 @@ library
                  pretty,
                  mtl,
                  exceptions,
-                 fail,
-                 -- For compatability with ghc < 8
-                 -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
-                 transformers-compat,
-                 ghc-prim
-  hs-source-dirs: src/runtime/haskell
-
-  other-modules:
-    -- 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
-
-  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,
+                 ghc-prim,
+                 filepath, directory>=1.2, time,
                  process, haskeline, parallel>=3, json
+  ghc-options: -threaded
 
-  hs-source-dirs: src/compiler
-  exposed-modules:
+  other-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
@@ -178,9 +109,9 @@ library
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Concrete
     GF.Compile.Compute.Predef
     GF.Compile.Compute.Value
+    GF.Compile.Compute.Concrete
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
@@ -188,16 +119,14 @@ library
     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
@@ -264,93 +193,38 @@ library
     GF.System.Directory
     GF.System.Process
     GF.System.Signal
+    GF.System.NoSignal
     GF.Text.Clitics
     GF.Text.Coding
+    GF.Text.Lexing
     GF.Text.Transliterations
     Paths_gf
-
-  if flag(c-runtime)
-    cpp-options: -DC_RUNTIME
-
-  if flag(server)
-    build-depends: httpd-shed>=0.4.0.3, network>=2.3 && <2.7,
-                   cgi>=3001.2.2.0
-    if flag(network-uri)
-      build-depends: network-uri>=2.6, network>=2.6
-    else
-      build-depends: network<2.6
-
-    cpp-options: -DSERVER_MODE
-    other-modules:
-      GF.Server
-      PGFService
-      RunHTTP
-      SimpleEditor.Convert
-      SimpleEditor.JSON
-      SimpleEditor.Syntax
-      URLEncoding
-      CGI
-      CGIUtils
-      Cache
-      Fold
-      ExampleDemo
-      ExampleService
-    hs-source-dirs: src/server src/server/transfer src/example-based
-
-  if flag(interrupt)
-    cpp-options: -DUSE_INTERRUPT
-    other-modules: GF.System.UseSignal
-  else
-    other-modules: GF.System.NoSignal
-
-  if impl(ghc>=7.8)
-    build-tools: happy>=1.19, alex>=3.1
---  ghc-options: +RTS -A20M -RTS
-  else
-    build-tools: happy, alex>=3
-
-  ghc-options: -fno-warn-tabs
+    
+    -- 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 os(windows)
-    build-depends: Win32
+    build-depends:
+      Win32 >= 2.3.1.1 && < 2.7
   else
-    build-depends: unix, terminfo>=0.4
-
-  if impl(ghc>=8.2)
-    ghc-options: -fhide-source-paths
-
-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
+    build-depends:
+      terminfo >=0.4.0 && < 0.5,
+      unix >= 2.7.2 && < 2.8
 
 test-suite gf-tests
-  type:           exitcode-stdio-1.0
-  main-is:        run.hs
+  type: exitcode-stdio-1.0
+  main-is: run.hs
   hs-source-dirs: testsuite
-  build-depends:  base>=4.3 && <5, Cabal>=1.8, directory, filepath, process
+  build-depends:
+    base >= 4.9.1 && < 4.15,
+    Cabal >= 1.8,
+    directory >= 1.3.0 && < 1.4,
+    filepath >= 1.4.1 && < 1.5,
+    process >= 1.4.3 && < 1.7
   build-tool-depends: gf:gf
-  default-language:    Haskell2010
+  default-language: Haskell2010

index.html

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

src/compiler/GF/Command/Abstract.hs

@@ -1,6 +1,6 @@
 module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Term) where
 
-import PGF(CId,mkCId,Expr,showExpr)
+import PGF2(Expr,showExpr)
 import GF.Grammar.Grammar(Term)
 
 type Ident = String
@@ -11,7 +11,7 @@ type Pipe = [Command]
 
 data Command
    = Command Ident [Option] Argument
-   deriving (Eq,Ord,Show)
+   deriving Show
 
 data Option
   = OOpt Ident
@@ -29,13 +29,7 @@ data Argument
   | ATerm Term
   | ANoArg
   | AMacro Ident
-  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
+  deriving Show
 
 valIntOpts :: String -> Int -> [Option] -> Int
 valIntOpts flag def opts =
@@ -49,6 +43,18 @@ 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,8 +3,7 @@ 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 qualified PGF as H(showExpr)
-import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ----
+import PGF2(mkStr,unStr,showExpr)
 
 data CommandInfo m = CommandInfo {
   exec     :: [Option] -> CommandArguments -> m CommandOutput,
@@ -38,21 +37,19 @@ class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
 
 --------------------------------------------------------------------------------
 
-data CommandArguments = Exprs [Expr] | Strings [String] | Term Term
+data CommandArguments = Exprs [(Expr,Float)] | Strings [String] | Term Term
 
 newtype CommandOutput = Piped (CommandArguments,String) ---- errors, etc
 
 -- ** Converting command output
 fromStrings ss         = Piped (Strings ss, unlines ss)
-fromExprs   es         = Piped (Exprs es,unlines (map (H.showExpr []) es))
+fromExprs show_p es    = Piped (Exprs es,unlines (map (\(e,p) -> (if show_p then (++) ("["++show p++"] ") else id) (showExpr [] e)) 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 =
@@ -61,23 +58,23 @@ toStrings args =
       Exprs es -> zipWith showAsString (True:repeat False) es
       Term t -> [render t]
   where
-    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
+    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
 
 toExprs args =
   case args of
-    Exprs es -> es
-    Strings ss -> map stringAsExpr ss
-    Term t -> [stringAsExpr (render t)]
+    Exprs es -> map fst es
+    Strings ss -> map mkStr ss
+    Term t -> [mkStr (render t)]
 
 toTerm args =
   case args of
     Term t -> t
     Strings ss -> string2term $ unwords ss -- hmm
-    Exprs es -> string2term $ unwords $ map (H.showExpr []) es -- hmm
+    Exprs es -> string2term $ unwords $ map (showExpr [] . fst) es -- hmm
 
 -- ** Creating documentation
 

src/compiler/GF/Command/Commands.hs

@@ -1,16 +1,12 @@
 {-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-}
 module GF.Command.Commands (
-  PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
+  HasPGF(..),pgfCommands,
   options,flags,
   ) where
-import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+import Prelude hiding (putStrLn,(<>))
 
-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 PGF2
+import PGF2.Internal(writePGF)
 
 import GF.Compile.Export
 import GF.Compile.ToAPI
@@ -28,28 +24,28 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute
 
 import GF.Data.Operations
 
-import PGF.Internal (encodeFile)
+import Data.Char
 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
 
 
-data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
+class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF)
 
-pgfEnv pgf = Env pgf mos
-  where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
+instance (Monad m,HasPGF m,Fail.MonadFail 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"
 
-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 :: HasPGF m => Map.Map String (CommandInfo m)
 pgfCommands = Map.fromList [
   ("aw", emptyCommandInfo {
      longname = "align_words",
@@ -62,7 +58,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 = getEnv $ \ opts arg (Env pgf mos) -> do
+     exec = needPGF $ \ opts arg pgf -> do
          let es = toExprs arg
          let langs = optLangs pgf opts
          if isOpt "giza" opts
@@ -74,7 +70,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 (graphvizAlignment pgf langs) es
+             let grphs = map (graphvizWordAlignment langs graphvizDefaults) es
              if isFlag "view" opts || isFlag "format" opts
                then do
                  let view = optViewGraph opts
@@ -96,6 +92,7 @@ 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",
@@ -106,16 +103,17 @@ 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  = 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,
+     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,
      flags = [
        ("clitics","the list of possible clitics (comma-separated, no spaces)"),
        ("lang",   "the language of analysis")
@@ -147,19 +145,19 @@ pgfCommands = Map.fromList [
        ],
      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")
+       ("lang","the language in which to parse")
        ],
-     exec = getEnv $ \ opts _ env@(Env pgf mos) -> do
+     exec = needPGF $ \opts _ pgf -> do
        let file = optFile opts
-       pgf <- optProbs opts pgf
        let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
-       let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer
+       concr <- optLang pgf opts
+       let conf = configureExBased pgf concr 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",
@@ -174,54 +172,53 @@ 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,",
-       "given in a file in the -probs flag."
+       "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")
        ],
      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)")
+       ("number","number of trees generated")
        ],
-     exec = getEnv $ \ opts arg (Env pgf mos) -> do
-       pgf <- optProbs opts (optRestricted opts pgf)
+     exec = needPGF $ \opts arg pgf -> do
        gen <- newStdGen
-       let dp = valIntOpts "depth" 4 opts
        let ts  = case mexp (toExprs arg) of
-                   Just ex -> generateRandomFromDepth gen pgf ex (Just dp)
-                   Nothing -> generateRandomDepth     gen pgf (optType pgf opts) (Just dp)
-       returnFromExprs $ take (optNum opts) ts
+                   Just ex -> generateRandomFrom gen pgf ex
+                   Nothing -> generateRandom     gen pgf (optType pgf opts)
+       returnFromExprs (isOpt "show_probs" opts) $ 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. By default, ",
-       "the depth is limited to 4, but this can be changed by a flag.",
+       "Generates all trees of a given category.",
        "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, to depth 4",
+       mkEx "gt                     -- all trees in the startcat",
        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 = 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
+     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
      }),
+
   ("i", emptyCommandInfo {
      longname = "import",
      synopsis = "import a grammar from source code or compiled .pgf file",
@@ -242,33 +239,28 @@ 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.",
-       "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."
+       "that it only affect the strings, not e.g. the table labels."
        ],
      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 "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
+       mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table"
        ],
-     exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings . optLins pgf opts $ toExprs ts,
+     exec = needPGF $ \ opts ts pgf -> 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"),
@@ -276,33 +268,13 @@ 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",
@@ -310,18 +282,20 @@ 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  = 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,
+     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,
      flags = [
        ("lang","the languages of analysis (comma-separated, no spaces)")
        ],
@@ -335,18 +309,16 @@ pgfCommands = Map.fromList [
      longname = "morpho_quiz",
      synopsis = "start a morphology quiz",
      syntax   = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
-     exec = getEnv $ \ opts arg (Env pgf mos) -> do
-         let lang = optLang pgf opts
+     exec = needPGF $ \ opts arg pgf -> do
+         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"),
-       ("probs","file with biased probabilities for generation")
+       ("number","maximum number of questions")
        ]
      }),
 
@@ -357,24 +329,25 @@ 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.",
-       "",
-       "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."
+       "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")
        ],
-     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)"),
-       ("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")
+       ("number","limit the results to the top N trees")
        ]
      }),
+
   ("pg", emptyCommandInfo { -----
      longname = "print_grammar",
      synopsis = "print the actual grammar with the given printer",
@@ -394,9 +367,8 @@ pgfCommands = Map.fromList [
         " " ++ opt ++ "\t\t" ++ expl |
            ((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
        ]),
-     exec  = getEnv $ \opts _ env -> prGrammar env opts,
+     exec  = needPGF $ \opts _ pgf -> prGrammar pgf 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)")
@@ -416,6 +388,7 @@ pgfCommands = Map.fromList [
        mkEx ("pg -funs | ? grep \" S ;\"  -- show functions with value cat S")
        ]
      }),
+
   ("pt", emptyCommandInfo {
      longname = "put_tree",
      syntax = "pt OPT? TREE",
@@ -429,11 +402,12 @@ pgfCommands = Map.fromList [
      examples = [
        mkEx "pt -compute (plus one two)                               -- compute value"
        ],
-     exec = getEnv $ \ opts arg (Env pgf mos) ->
-            returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg,
+     exec = needPGF $ \opts arg pgf ->
+            returnFromExprs False .  takeOptNum opts . map (flip (,) 0) . 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",
@@ -446,10 +420,9 @@ 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 = getEnv $ \ opts _ (Env pgf mos) -> do
+     exec = needPGF $ \ opts _ pgf -> do
        let file = valStrOpts "file" "_gftmp" opts
        let exprs []         = ([],empty)
            exprs ((n,s):ls) | null s
@@ -458,12 +431,12 @@ pgfCommands = Map.fromList [
                                 Just e  -> let (es,err) = exprs ls
                                            in case inferExpr pgf e of
                                                 Right (e,t) -> (e:es,err)
-                                                Left tcerr  -> (es,"on line" <+> n <> ':' $$ nest 2 (ppTcError tcerr) $$ err)
+                                                Left err    -> (es,"on line" <+> n <> ':' $$ nest 2 err $$ 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 es (render err)
+                                            | otherwise -> return $ pipeWithMessage (map (flip (,) 0) es) (render err)
 
        s <- restricted $ readFile file
        case opts of
@@ -472,56 +445,26 @@ 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 = getEnv $ \ opts arg (Env pgf mos) -> do
-         let from = optLangFlag "from" pgf opts
-         let to   = optLangFlag "to" pgf opts
+     exec = needPGF $ \ opts arg pgf -> do
+         from <- optLangFlag "from" pgf opts
+         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"),
-       ("probs","file with biased probabilities for generation")
+       ("number","the maximum number of questions")
        ],
      examples = [
        mkEx ("tq -from=Eng -to=Swe                               -- any trees in startcat"),
@@ -529,7 +472,6 @@ pgfCommands = Map.fromList [
        ]
      }),
 
-
   ("vd", emptyCommandInfo {
      longname = "visualize_dependency",
      synopsis = "show word dependency tree graphically",
@@ -547,7 +489,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 = getEnv $ \ opts arg (Env pgf mos) -> do
+     exec = needPGF $ \ opts arg pgf -> do
          let absname = abstractName pgf
          let es = toExprs arg
          let debug = isOpt "v" opts
@@ -560,8 +502,8 @@ pgfCommands = Map.fromList [
          mclab <- case cnclabels of
            "" -> return Nothing
            _  -> (Just . getCncDepLabels) `fmap` restricted (readFile cnclabels)
-         let lang = optLang pgf opts
-         let grphs = map (graphvizDependencyTree outp debug mlab mclab pgf lang) es
+         concr <- optLang pgf opts
+         let grphs = map (graphvizDependencyTree outp debug mlab mclab concr) es
          if isOpt "conll2latex" opts
            then return $ fromString $ conlls2latexDoc $ stanzas $ unlines $ toStrings arg
            else if isFlag "view" opts && valStrOpts "output" "" opts == "latex"
@@ -596,7 +538,6 @@ pgfCommands = Map.fromList [
        ]
     }),
 
-
   ("vp", emptyCommandInfo {
      longname = "visualize_parse",
      synopsis = "show parse tree graphically",
@@ -608,9 +549,8 @@ 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 = getEnv $ \ opts arg (Env pgf mos) -> do
-         let es = toExprs arg
-         let lang = optLang pgf opts
+     exec = needPGF $ \opts arg pgf -> do
+         let es        = toExprs arg
          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),
@@ -623,10 +563,11 @@ 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 (graphvizParseTreeDep mlab pgf lang gvOptions) es
+         let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es
          if isFlag "view" opts || isFlag "format" opts
            then do
              let view = optViewGraph opts
@@ -661,7 +602,6 @@ pgfCommands = Map.fromList [
        ]
     }),
 
-
   ("vt", emptyCommandInfo {
      longname = "visualize_tree",
      synopsis = "show a set of trees graphically",
@@ -674,7 +614,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 = getEnv $ \ opts arg (Env pgf mos) ->
+     exec = needPGF $ \opts arg pgf ->
       let es = toExprs arg in
        if isOpt "mk" opts
        then return $ fromString $ unlines $ map (tree2mk pgf) es
@@ -686,7 +626,7 @@ pgfCommands = Map.fromList [
        else do
          let funs = not (isOpt "nofun" opts)
          let cats = not (isOpt "nocat" opts)
-         let grphs = map (graphvizAbstractTree pgf (funs,cats)) es
+         let grphs = map (graphvizAbstractTree pgf (graphvizDefaults{noFun=funs,noCat=cats})) es
          if isFlag "view" opts || isFlag "format" opts
            then do
              let view = optViewGraph opts
@@ -708,6 +648,7 @@ pgfCommands = Map.fromList [
        ("view","program to open the resulting file (default \"open\")")
        ]
      }),
+
   ("ai", emptyCommandInfo {
      longname = "abstract_info",
      syntax = "ai IDENTIFIER  or  ai EXPR",
@@ -720,205 +661,150 @@ pgfCommands = Map.fromList [
        "If a whole expression is given it prints the expression with refined",
        "metavariables and the type of the expression."
        ],
-     exec = getEnv $ \ opts arg (Env pgf mos) -> do
+     exec = needPGF $ \opts arg pgf -> do
        case toExprs arg of
-         [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   -> errorWithoutStackTrace $ render (ppTcError tcErr)
-                          Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
-                                             putStrLn ("Type:        "++showType [] ty)
-                                             putStrLn ("Probability: "++show (probTree pgf e))
-                                             return void
+         [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
          _           -> do putStrLn "a single identifier or expression is expected from the command"
                            return void,
      needsTypeCheck = False
      })
   ]
  where
-   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
+   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"
 
    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,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))
+   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"
 
-   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
+   optLins pgf opts ts = concatMap (optLin pgf opts) ts
    optLin pgf opts t =
      case opts of
-       _ | isOpt "treebank" opts && isOpt "chunks" 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 ->
-         (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 | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
-   linChunks pgf opts t = 
-     [(lang, unwords (intersperse "<+>" (map (unlines . linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts]
+         (abstractName pgf ++ ": " ++ showExpr [] t) :
+         [concreteName concr ++ ": " ++ s | concr <- optLangs pgf opts, s<-linear opts concr t]
+       _ -> [s | concr <- optLangs pgf opts, s <- linear opts concr t]
 
-   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
+   linear :: [Option] -> Concr -> Expr -> [String]
+   linear opts concr = case opts of
+       _ | isOpt "all"     opts -> concat .
+                                   map (map snd) . tabularLinearizeAll concr
        _ | isOpt "list"    opts -> (:[]) . commaList . concat .
-                                   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
+                                   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
 
    -- 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 = 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
-       _ -> []
+               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
 
    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"
 
-   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))
+   optLangFlag flag pgf opts =
+     case optLangsFlag flag pgf opts of
+       []     -> fail "no language specified"
+       (l:ls) -> return l
 
-   optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [wildCId]
+   optLangsFlag flag pgf opts =
+     case valStrOpts flag "" opts of
+       ""  -> Map.elems langs
+       str -> mapMaybe (completeLang pgf) (chunks ',' str)
+     where
+       langs = languages pgf
 
-   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)
+       completeLang pgf la =
+         mplus (Map.lookup la                       langs)
+               (Map.lookup (abstractName pgf ++ la) langs)
 
    optFile opts = valStrOpts "file" "_gftmp" opts
 
    optType pgf 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")
+     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
    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 es = return $ case es of
-     [] -> pipeMessage "no trees found"
-     _  -> fromExprs es
+   returnFromExprs show_p es =
+     return $ 
+       case es of
+         [] -> pipeMessage "no trees found"
+         _  -> fromExprs show_p es
 
-   prGrammar (Env pgf mos) opts
+   prGrammar pgf opts
      | isOpt "pgf"      opts = do
-          let pgf1 = if isOpt "opt" opts then optimizePGF pgf else pgf
-          let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts
-          restricted $ encodeFile outfile pgf1
+          let outfile = valStrOpts "file" (abstractName pgf ++ ".pgf") opts
+          restricted $ writePGF outfile pgf
           putStrLn $ "wrote file " ++ outfile
           return void
-     | 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 "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 "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
+     | 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
      | otherwise             = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
                                   return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
 
-   funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
-   showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
+   showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
+                       where
+                         kwd | functionIsDataCon pgf id = "data"
+                             | otherwise                = "fun"
 
-   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))
+   morphos pgf opts s =
+     [(s,lookupMorpho concr s) | concr <- optLangs pgf opts]
 
    optClitics opts = case valStrOpts "clitics" "" opts of
      "" -> []
@@ -931,18 +817,28 @@ 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 (mkCId x)
+     app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f 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 -> Language -> Language -> Type -> IO ()
+translationQuiz :: Maybe Expr -> PGF -> Concr -> Concr -> 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 -> Language -> Type -> IO ()
+morphologyQuiz :: Maybe Expr -> PGF -> Concr -> Type -> IO ()
 morphologyQuiz mex pgf ig typ = do
   tts <- morphologyList mex pgf ig typ infinity
   mkQuiz "Welcome to GF Morphology Quiz." tts
@@ -951,30 +847,28 @@ morphologyQuiz mex pgf ig typ = do
 infinity :: Int
 infinity = 256
 
-prLexcLexicon :: Morpho -> String
-prLexcLexicon mo =
-  unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w  ++ " # ;" | (w,lps) <- morpho, (l,p) <- lps] ++ ["END"]
+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 mo
-  prLexc l p = showCId l ++ concat (mkTags (words p))
+  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 # ;
+  multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
 
-prFullFormLexicon :: Morpho -> String
-prFullFormLexicon mo =
-  unlines (map prMorphoAnalysis (fullFormLexicon mo))
+prFullFormLexicon :: Concr -> String
+prFullFormLexicon concr =
+  unlines (map prMorphoAnalysis (fullFormLexicon concr))
 
-prAllWords :: Morpho -> String
-prAllWords mo =
-  unwords [w | (w,_) <- fullFormLexicon mo]
+prAllWords :: Concr -> String
+prAllWords concr =
+  unwords [w | (w,_) <- fullFormLexicon concr]
 
-prMorphoAnalysis :: (String,[(Lemma,Analysis)]) -> String
 prMorphoAnalysis (w,lps) =
-  unlines (w:[showCId l ++ " : " ++ p | (l,p) <- lps])
+  unlines (w:[l ++ " : " ++ p ++ show prob | (l,p,prob) <- lps])
 
 viewGraphviz :: String -> String -> String -> [String] -> SIO CommandOutput
 viewGraphviz view format name grphs = do
@@ -1022,4 +916,4 @@ stanzas = map unlines . chop . lines where
 
 #if !(MIN_VERSION_base(4,9,0))
 errorWithoutStackTrace = error
-#endif
+#endif

src/compiler/GF/Command/Commands2.hs

@@ -1,831 +0,0 @@
-{-# 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,7 +3,6 @@
 -- 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
@@ -17,7 +16,7 @@ import GF.Text.Transliterations
 import GF.Text.Lexing(stringOp,opInEnv)
 import Data.Char (isSpace)
 
-import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
+import PGF2(showExpr)
 
 extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
 
@@ -103,9 +102,7 @@ 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",
@@ -118,13 +115,11 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
                let (os,fs) = optsAndFlags opts
                trans <- optTranslit opts
 
-               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),
+               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),
      options = [
-       ("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")
+       ("lines","apply the operation separately to each input line, returning a list of lines")
        ] ++
        stringOpOptions,
      flags = [
@@ -180,12 +175,6 @@ 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",
@@ -233,7 +222,6 @@ 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)"),
@@ -258,27 +246,6 @@ 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 PGF
-import PGF.Internal(optimizePGF,unionPGF,msgUnionPGF)
+import PGF2
+import PGF2.Internal(unionPGF)
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)
@@ -17,14 +17,16 @@ 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 :: PGF -> Options -> [FilePath] -> IO PGF
-importGrammar pgf0 _ [] = return pgf0
+importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
+importGrammar pgf0 _    []    = return pgf0
 importGrammar pgf0 opts files =
   case takeExtensions (last files) of
-    ".cf"   -> importCF opts files getBNFCRules bnfc2cf
-    ".ebnf" -> importCF opts files getEBNFRules ebnf2cf
+    ".cf"   -> fmap Just $ importCF opts files getBNFCRules bnfc2cf
+    ".ebnf" -> fmap Just $ importCF opts files getEBNFRules ebnf2cf
     ".gfm"  -> do
       ascss <- mapM readMulti files
       let cs = concatMap snd ascss
@@ -36,14 +38,15 @@ importGrammar pgf0 opts files =
         Bad msg -> do putStrLn ('\n':'\n':msg)
                       return pgf0
     ".pgf" -> do
-      pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
-      ioUnionPGF pgf0 pgf2
+      mapM readPGF files >>= foldM ioUnionPGF pgf0
     ext -> die $ "Unknown filename extension: " ++ show ext
 
-ioUnionPGF :: PGF -> PGF -> IO PGF
-ioUnionPGF one two = case msgUnionPGF one two of
-  (pgf, Just msg) -> putStrLn msg >> return pgf
-  (pgf,_)         -> return pgf
+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)
 
 importSource :: Options -> [FilePath] -> IO SourceGrammar
 importSource opts files = fmap (snd.snd) (batchCompile opts files)
@@ -56,7 +59,6 @@ importCF opts files get convert = impCF
       startCat <- case rules of
                     (Rule cat _ _ : _) -> return cat
                     _                  -> fail "empty CFG"
-      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
+      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
+      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
+      return pgf

src/compiler/GF/Command/Interpreter.hs

@@ -6,8 +6,8 @@ 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
@@ -56,17 +56,8 @@ 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 (app e))
+  AExpr e -> Command i os (AExpr (exprSubstitute e (toExprs args)))
   _       -> 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
@@ -113,4 +104,4 @@ getCommandTrees env needsTypeCheck a args =
     ATerm t -> return (Term t)
     ANoArg  -> return args  -- use piped
   where
-    one e = return (Exprs [e]) -- ignore piped
+    one e = return (Exprs [(e,0)]) -- ignore piped

src/compiler/GF/Command/Parse.hs

@@ -1,6 +1,6 @@
 module GF.Command.Parse(readCommandLine, pCommand) where
 
-import PGF(pExpr,pIdent)
+import PGF2(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  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
+  cmd  <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P 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 <- pIdent
+  flg <- readS_to_P 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 pExpr
+    (fmap AExpr (readS_to_P pExpr)
               <++
-    (skipSpaces >> char '%' >> fmap AMacro pIdent))
+    (skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent)))
 
 pArgTerm = ATerm `fmap` readS_to_P sTerm
   where

src/compiler/GF/Command/TreeOperations.hs

@@ -1,18 +1,17 @@
 module GF.Command.TreeOperations (
   treeOp,
   allTreeOps,
-  treeChunks
   ) where
 
-import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
+import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unMeta,exprSize,exprFunctions)
 import Data.List
 
 type TreeOp = [Expr] -> [Expr]
 
-treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp))
+treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
 treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
 
-allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))]
+allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
 allTreeOps pgf = [
    ("compute",("compute by using semantic definitions (def)",
       Left  $ map (compute pgf))),
@@ -34,16 +33,6 @@ largest = reverse . smallest
 smallest :: [Expr] -> [Expr]
 smallest = sortBy (\t u -> compare (exprSize t) (exprSize u))
 
-treeChunks :: Expr -> [Expr]
-treeChunks = snd . cks where
-  cks t = 
-    case unapply t of
-      (t, ts) -> case unMeta t of
-                   Just _  -> (False,concatMap (snd . cks) ts)
-                   Nothing -> case unzip (map cks ts) of
-                                (bs,_) | and bs      -> (True, [t])
-                                (_,cts)              -> (False,concat cts)
-
 subtrees :: Expr -> [Expr]
 subtrees t = t : case unApp t of
   Just (f,ts) -> concatMap subtrees ts

src/compiler/GF/Compile.hs

@@ -1,6 +1,6 @@
 module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
 
-import GF.Compile.GrammarToPGF(mkCanon2pgf)
+import GF.Compile.GrammarToPGF(grammar2PGF)
 import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
                             importsOfModule)
 import GF.CompileOne(compileOne)
@@ -14,7 +14,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
                       justModuleName,extendPathEnv,putStrE,putPointE)
 import GF.Data.Operations(raise,(+++),err)
 
-import Control.Monad(foldM,when,(<=<),filterM,liftM)
+import Control.Monad(foldM,when,(<=<))
 import GF.System.Directory(doesFileExist,getModificationTime)
 import System.FilePath((</>),isRelative,dropFileName)
 import qualified Data.Map as Map(empty,insert,elems) --lookup
@@ -22,8 +22,7 @@ import Data.List(nub)
 import Data.Time(UTCTime)
 import GF.Text.Pretty(render,($$),(<+>),nest)
 
-import PGF.Internal(optimizePGF)
-import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
+import PGF2(PGF,readProbabilitiesFromFile)
 
 -- | Compiles a number of source files and builds a 'PGF' structure for them.
 -- This is a composition of 'link' and 'batchCompile'.
@@ -36,11 +35,10 @@ link :: Options -> (ModuleName,Grammar) -> IOE PGF
 link opts (cnc,gr) =
   putPointE Normal opts "linking ... " $ do
     let abs = srcAbsName gr cnc
-    pgf <- mkCanon2pgf opts gr abs
-    probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
+    probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
+    pgf <- grammar2PGF opts gr abs probs
     when (verbAtLeast opts Normal) $ putStrE "OK"
-    return $ setProbabilities probs 
-           $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
+    return pgf
 
 -- | Returns the name of the abstract syntax corresponding to the named concrete syntax
 srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
@@ -78,14 +76,10 @@ compileModule opts1 env@(_,rfs) file =
   do file <- getRealFile file
      opts0 <- getOptionsFromFile file
      let curr_dir = dropFileName file
-     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 ----
+     lib_dir  <- getLibraryDirectory (addOptions opts0 opts1)
+     let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
      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 ----
@@ -98,17 +92,13 @@ compileModule opts1 env@(_,rfs) file =
       if exists
         then return file
         else if isRelative file
-               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"))
+               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."))
 
 compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
 compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -1,99 +1,110 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, ImplicitParams #-}
 module GF.Compile.CFGtoPGF (cf2pgf) where
 
 import GF.Grammar.CFG
 import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Compile.OptimizePGF
 
-import PGF
-import PGF.Internal
+import PGF2
+import PGF2.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 :: FilePath -> ParamCFG -> PGF
-cf2pgf fpath cf = 
- let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
- in updateProductionIndices pgf
+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)])
  where
    name = justModuleName fpath
-   aname = mkCId (name ++ "Abs")
-   cname = mkCId name
+   aname = name ++ "Abs"
+   cname = name
 
-cf2abstr :: ParamCFG -> Abstr
-cf2abstr cfg = Abstr aflags afuns acats
+cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
+cf2abstr cfg probs = newAbstr aflags acats afuns
   where
-    aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
+    aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
 
-    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]
+    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]
 
-    cat2id = mkCId . fst
+    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)
 
-cf2concr :: ParamCFG -> Concr
-cf2concr cfg = Concr Map.empty Map.empty
-                     cncfuns lindefsrefs lindefsrefs
-                     sequences productions
-                     IntMap.empty Map.empty
-                     cnccats
-                     IntMap.empty
-                     totalCats
+    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
   where
     cats  = allCats' cfg
     rules = allRules cfg
 
-    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : 
-                               map mkSequence rules)
-    sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
+    idSeq = [SymCat 0 0]
 
-    idFun = CncFun wildCId (listArray (0,0) [seqid])
-      where
-        seq   = listArray (0,0) [SymCat 0 0]
-        seqid = binSearch seq sequences (bounds sequences)
+    sequences0 = Set.fromList (idSeq : 
+                               map mkSequence rules)
+    sequences  = Set.toList sequences0
+
+    idFun = ("_",[Set.findIndex idSeq sequences0])
     ((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
     productions = foldl addProd IntMap.empty (concat (productions0++coercions))
-    cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
+    cncfuns = reverse cncfuns0
 
-    lbls = listArray (0,0) ["s"]
-    (fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
-                              [(c,p) | (c,ps) <- cats, p <- ps]
+    lbls = ["s"]
+    (fid,cnccats) = (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 =
-       IntMap.fromList (map mkLinDefRef cats)
+    lindefsrefs = map mkLinDefRef cats
 
     convertRule cs (funid,funs) rule =
       let args   = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
           prod   = PApply funid args
-          seqid  = binSearch (mkSequence rule) sequences (bounds sequences)
-          fun    = CncFun (mkRuleName rule) (listArray (0,0) [seqid])
+          seqid  = Set.findIndex (mkSequence rule) sequences0
+          fun    = (mkRuleName rule, [seqid])
           funid' = funid+1
       in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
 
-    mkSequence rule = listArray (0,length syms-1) syms
+    mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
       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, (mkCId cat, CncCat fidInt    fidInt    lbls))
-      | cat == "Float"  = (fid, (mkCId cat, CncCat fidFloat  fidFloat  lbls))
-      | cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
+      | cat == "Int"    = (fid, (cat, fidInt,    fidInt,    lbls))
+      | cat == "Float"  = (fid, (cat, fidFloat,  fidFloat,  lbls))
+      | cat == "String" = (fid, (cat, fidString, fidString, lbls))
       | otherwise       = let fid' = fid+n+1
-                          in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
+                          in fid' `seq` (fid', (cat, fid, fid+n, lbls))
 
     mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
     mkCoercions (fid,cs) c@(cat,ps ) =
@@ -102,25 +113,16 @@ cf2concr cfg = Concr Map.empty Map.empty
 
     mkLinDefRef (cat,_) =
       (cat2fid cat 0,[0])
-      
+
     addProd prods (fid,prod) =
       case IntMap.lookup fid prods of
-        Just set -> IntMap.insert fid (Set.insert prod set) prods
-        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
+        Just set -> IntMap.insert fid (prod:set) prods
+        Nothing  -> IntMap.insert fid [prod]     prods
 
     cat2fid cat p =
-      case Map.lookup (mkCId cat) cnccats of
-        Just (CncCat fid _ _) -> fid+p
-        _                     -> error "cat2fid"
+      case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
+        (start:_) -> fid+p
+        _         -> error "cat2fid"
 
     cat2arg c@(cat,[p]) = cat2fid cat p
     cat2arg c@(cat,ps ) =
@@ -131,4 +133,4 @@ cf2concr cfg = Concr Map.empty Map.empty
 mkRuleName rule =
   case ruleName rule of
 	CFObj n _ -> n
-	_         -> wildCId
+	_         -> "_"

src/compiler/GF/Compile/CheckGrammar.hs

@@ -21,8 +21,8 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.CheckGrammar(checkModule) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
+import Prelude hiding ((<>))
 import GF.Infra.Ident
 import GF.Infra.Option
 
@@ -175,7 +175,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
         checkTyp gr typ
       case md of
         Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
-	                                        checkDef gr (m,c) typ eq) eqs
+                                          checkDef gr (m,c) typ eq) eqs
         Nothing  -> return ()
       return (AbsFun (Just (L loc typ)) ma md moper)
 
@@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do
    mkLinArg (i,(n,mc@(m,cat))) = do
      val  <- lookLin mc
      let vars = mkRecType varLabel $ replicate n typeStr
-	 symb = argIdent n cat i
+         symb = argIdent n cat i
      rec <- if n==0 then return val else
                        errIn (render ("extending" $$
                                       nest 2 vars $$

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

@@ -30,11 +30,12 @@ import Debug.Trace(trace)
 normalForm :: GlobalEnv -> L Ident -> Term -> Term
 normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
 
+nfx :: GlobalEnv -> Term -> Err Term
 nfx env@(GE _ _ _ loc) t = do
   v <- eval env [] t
-  case value2term loc [] v of
-    Left i  -> fail ("variable #"++show i++" is out of scope")
-    Right t -> return t
+  return (value2term loc [] v)
+    -- Old value2term error message:
+    -- Left i  -> fail ("variable #"++show i++" is out of scope")
 
 eval :: GlobalEnv -> Env -> Term -> Err Value
 eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
@@ -288,9 +289,9 @@ glue env (v1,v2) = glu v1 v2
           (v1,v2) -> if flag optPlusAsBind (opts env)
                        then VC v1 (VC (VApp BIND []) v2)
                        else let loc  = gloc env
-                                vt v = case value2term loc (local env) v of
-                                         Left i  -> Error ('#':show i)
-                                         Right t -> t
+                                vt v = value2term loc (local env) v
+                                        -- Old value2term error message:
+                                        --  Left i  -> Error ('#':show i)
                                 originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
                                                                (Glue (vt v1) (vt v2)))
                                 term = render $ pp  $ Glue (vt v1) (vt v2)
@@ -355,9 +356,9 @@ select env vv =
       (v1,v2) -> ok2 VS v1 v2
 
 match loc cs v =
-  case value2term loc [] v of
-    Left i  -> bad ("variable #"++show i++" is out of scope")
-    Right t -> err bad return (matchPattern cs t)
+  err bad return (matchPattern cs (value2term loc [] v))
+    -- Old value2term error message:
+    -- Left i  -> bad ("variable #"++show i++" is out of scope")
   where
     bad = fail . ("In pattern matching: "++)
 
@@ -383,9 +384,8 @@ valueTable env i cs =
     wild = case i of TWild _ -> True; _ -> False
 
     convertv cs' vty =
-      case value2term (gloc env) [] vty of
-        Left i    -> fail ("variable #"++show i++" is out of scope")
-        Right pty -> convert' cs' =<< paramValues'' env pty
+      convert' cs' =<< paramValues'' env (value2term (gloc env) [] vty)
+        -- Old value2term error message: Left i    -> fail ("variable #"++show i++" is out of scope")
 
     convert cs' ty = convert' cs' =<< paramValues' env ty
 
@@ -492,58 +492,60 @@ vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
     pf (_,VString n) = pp n
     pf (_,v) = ppV v
     pa (_,v) = ppV v
-    ppV v = case value2term' True loc [] v of
-              Left i  -> "variable #" <> pp i <+> "is out of scope"
-              Right t -> ppTerm Unqualified 10 t
+    ppV v = ppTerm Unqualified 10 (value2term' True loc [] v)
+              -- Old value2term error message:
+              -- Left i  -> "variable #" <> pp i <+> "is out of scope"
 
 -- | Convert a value back to a term
-value2term :: GLocation -> [Ident] -> Value -> Either Int Term
+value2term :: GLocation -> [Ident] -> Value -> Term
 value2term = value2term' False
+
+value2term' :: Bool -> p -> [Ident] -> Value -> Term
 value2term' stop loc xs v0 =
   case v0 of
-    VApp pre vs    -> liftM (foldl App (Q (cPredef,predefName pre))) (mapM v2t vs)
-    VCApp f vs     -> liftM  (foldl App (QC f))   (mapM v2t vs)
-    VGen j vs      -> liftM2 (foldl App) (var j)  (mapM v2t vs)
-    VMeta j env vs -> liftM  (foldl App (Meta j)) (mapM v2t vs)
-    VProd bt v x f -> liftM2 (Prod bt x) (v2t v) (v2t' x f)
-    VAbs  bt   x f -> liftM  (Abs  bt x)         (v2t' x f)
-    VInt n         -> return (EInt n)
-    VFloat f       -> return (EFloat f)
-    VString s      -> return (if null s then Empty else K s)
-    VSort s        -> return (Sort s)
-    VImplArg v     -> liftM  ImplArg (v2t v)
-    VTblType p res -> liftM2 Table (v2t p) (v2t res)
-    VRecType rs    -> liftM  RecType (mapM (\(l,v) -> fmap ((,) l) (v2t v)) rs)
-    VRec as        -> liftM  R       (mapM (\(l,v) -> v2t v >>= \t -> return (l,(Nothing,t))) as)
-    VV t _ vs      -> liftM  (V t)   (mapM v2t vs)
-    VT wild v cs   -> v2t v >>= \t -> liftM (T ((if wild then TWild else TTyped) t)) (mapM nfcase cs)
-    VFV vs         -> liftM  FV (mapM v2t vs)
-    VC v1 v2       -> liftM2 C (v2t v1) (v2t v2)
-    VS v1 v2       -> liftM2 S (v2t v1) (v2t v2)
-    VP v l         -> v2t v >>= \t -> return (P t l)
-    VPatt p        -> return (EPatt p)
-    VPattType v    -> v2t v >>= return . EPattType
-    VAlts v vvs    -> liftM2 Alts (v2t v) (mapM (\(x,y) -> liftM2 (,) (v2t x) (v2t y)) vvs)
-    VStrs vs       -> liftM  Strs (mapM v2t vs)
+    VApp pre vs    -> applyMany (Q (cPredef,predefName pre)) vs
+    VCApp f vs     -> applyMany (QC f)                       vs
+    VGen j vs      -> applyMany (var j)                      vs
+    VMeta j env vs -> applyMany (Meta j)                     vs
+    VProd bt v x f -> Prod bt x (v2t v)  (v2t' x f)
+    VAbs  bt   x f -> Abs  bt x          (v2t' x f)
+    VInt n         -> EInt n
+    VFloat f       -> EFloat f
+    VString s      -> if null s then Empty else K s
+    VSort s        -> Sort s
+    VImplArg v     -> ImplArg (v2t v)
+    VTblType p res -> Table (v2t p) (v2t res)
+    VRecType rs    -> RecType [(l, v2t v) | (l,v) <- rs]
+    VRec as        -> R       [(l, (Nothing, v2t v)) | (l,v) <- as]
+    VV t _ vs      -> V t     (map v2t vs)
+    VT wild v cs   -> T ((if wild then TWild else TTyped) (v2t v)) (map nfcase cs)
+    VFV vs         -> FV (map v2t vs)
+    VC v1 v2       -> C (v2t v1) (v2t v2)
+    VS v1 v2       -> S (v2t v1) (v2t v2)
+    VP v l         -> P (v2t v) l
+    VPatt p        -> EPatt p
+    VPattType v    -> EPattType $ v2t v
+    VAlts v vvs    -> Alts (v2t v) [(v2t x, v2t y) | (x,y) <- vvs]
+    VStrs vs       -> Strs (map v2t vs)
 --  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
 --  VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
-    VError err     -> return (Error err)
-
+    VError err     -> Error err
   where
+    applyMany f vs = foldl App f (map v2t vs)
     v2t = v2txs xs
     v2txs = value2term' stop loc
     v2t' x f = v2txs (x:xs) (bind f (gen xs))
 
     var j
-      | j<length xs = Right (Vr (reverse xs !! j))
-      | otherwise   = Left  j
+      | j<length xs = Vr (reverse xs !! j)
+      | otherwise   = error ("variable #"++show j++" is out of scope")
 
 
     pushs xs e = foldr push e xs
     push x (env,xs) = ((x,gen xs):env,x:xs)
     gen xs = VGen (length xs) []
 
-    nfcase (p,f) = liftM ((,) p) (v2txs xs' (bind f env'))
+    nfcase (p,f) = (,) p (v2txs xs' (bind f env'))
       where (env',xs') = pushs (pattVars p) ([],xs)
 
     bind (Bind f) x = if stop

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

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

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

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

src/compiler/GF/Compile/ExampleBased.hs

@@ -3,11 +3,7 @@ module GF.Compile.ExampleBased (
   configureExBased
   ) where
 
-import PGF
---import PGF.Probabilistic
---import PGF.Morphology
---import GF.Compile.ToAPI
-
+import PGF2
 import Data.List
 
 parseExamplesInGrammar :: ExConfiguration -> FilePath -> IO (FilePath,[String])
@@ -37,47 +33,38 @@ 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 fst (parse_ pgf lang typ (Just 4) ex) of
-      ParseFailed _ -> do
-        let ws = morphoMissing morpho (words ex)
+    ws <- case parse lang typ ex of
+      ParseFailed _ _ -> do
         appv ("WARNING: cannot parse example " ++ ex) 
-        case ws of
-          [] -> return ()
-          _  -> appv ("  missing words: " ++ unwords ws)
-        return ws
-      TypeError _ ->
         return []
       ParseIncomplete ->
         return []
       ParseOk ts ->
-        case rank ts of
+        case ts of
           (t:tt) -> do
             if null tt 
               then return ()
               else appv ("WARNING: ambiguous example " ++ ex) 
-            appn t 
-            mapM_ (appn . ("  --- " ++)) tt
+            appn (printExp conf (fst t))
+            mapM_ (appn . ("  --- " ++) . printExp conf . fst) 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_morpho :: Morpho,
+  resource_pgf :: PGF,
   verbose  :: Bool,
-  language :: Language,
-  printExp :: Tree -> String
+  language :: Concr,
+  printExp :: Expr -> String
   }
 
-configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration
-configureExBased pgf morpho lang pr = ExConf pgf morpho False lang pr
+configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
+configureExBased pgf concr pr = ExConf pgf False concr pr
 

src/compiler/GF/Compile/Export.hs

@@ -1,14 +1,10 @@
 module GF.Compile.Export where
 
-import PGF
-import PGF.Internal(ppPGF)
+import PGF2
 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
@@ -22,6 +18,7 @@ import GF.Speech.SLF
 import GF.Speech.PrRegExp
 
 import Data.Maybe
+import qualified Data.Map as Map
 import System.FilePath
 import GF.Text.Pretty
 
@@ -35,15 +32,12 @@ exportPGF :: Options
           -> [(FilePath,String)] -- ^ List of recommended file names and contents.
 exportPGF opts fmt pgf = 
     case fmt of
-      FmtPGFPretty    -> multi "txt" (render . ppPGF)
+      FmtPGFPretty    -> multi "txt" (showPGF)
       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)
@@ -57,20 +51,13 @@ exportPGF opts fmt pgf =
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
  where
-   name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
+   name = fromMaybe (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 -> CId -> String) -> [(FilePath,String)]
-   single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]
+   single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
+   single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (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 PGF(CId,utf8CId)
-import PGF.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
+import PGF2.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 (i2i id)
+        (Q (_,id)) -> CASE (showIdent 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 (i2i id)) args)
+       -> (h0,bs,eval st (GLOBAL (showIdent 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 (i2i id)) [])
+                      then (h0,bs,eval st (GLOBAL (showIdent id)) [])
                       else let h1  = h0 + 2 + n_args
-                           in (h1,bs,PUT_CONSTR (i2i id):is1++eval st (HEAP h0) [])
+                           in (h1,bs,PUT_CONSTR (showIdent 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 (i2i id) : 
+                              PUT_CONSTR (showIdent 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 (i2i id),[])
+    Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
     _             -> let Ok ty = lookupFunType gr m id
                          (ctxt,_,_) = typeForm ty
                          c_arity    = length ctxt
                      in if c_arity == 0
-                          then (h0,bs,GLOBAL (i2i id),[])
+                          then (h0,bs,GLOBAL (showIdent 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 (i2i id) :
+                                         PUT_CONSTR (showIdent 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 (i2i id) : is2))
+                      in (h2,bs1,HEAP h1,is1 ++ (PUT_CONSTR (showIdent 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 (i2i id) :
+                                PUT_CONSTR (showIdent id) :
                                 is2 ++
                                 TUCK (ARG_VAR 0) diff :
                                 EVAL (HEAP h0) (TailCall diff) :
@@ -298,9 +298,6 @@ 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,8 +13,9 @@ module GF.Compile.GeneratePMCFG
     (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
     ) where
 
---import PGF.CId
-import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)
+import qualified PGF2 as PGF2
+import qualified PGF2.Internal as PGF2
+import PGF2.Internal(Symbol(..),fidVar)
 
 import GF.Infra.Option
 import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -69,7 +70,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 (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
+addPMCFG opts gr cenv opath am cm seqs id (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 +94,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
     ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
   seqs1 `seq` stats `seq` return ()
   when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
-  return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
+  return (seqs1,CncFun mty mlin mprn (Just pmcfg))
   where
     (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
 
@@ -103,11 +104,11 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
           newArgs  = map getFIds newArgs'
       in addFunction env0 newCat fun newArgs
 
-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
-                                                             mdef@(Just (L loc1 def))
-                                                             mref@(Just (L loc2 ref))
-                                                             mprn
-                                                             Nothing) = do
+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
   let pcat = protoFCat gr (am,id) lincat
       pvar = protoFCat gr (MN identW,cVar) typeStr
 
@@ -132,7 +133,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
   let pmcfg     = getPMCFG pmcfgEnv2
 
   when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
-  seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
+  seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
   where
     addLindef lins (newCat', newArgs') env0 =
       let [newCat] = getFIds newCat'
@@ -158,12 +159,15 @@ convert opts gr cenv loc term ty@(_,val) pargs =
             args = map Vr vars
             vars = map (\(bt,x,t) -> x) context
 
-pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
-pgfCncCat gr lincat index =
+pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
+pgfCncCat gr id lincat index =
   let ((_,size),schema) = computeCatRange gr lincat
-  in PGF.CncCat index (index+size-1)
-                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
-                                    (getStrPaths schema)))
+  in ( id
+     , index
+     , index+size-1
+     , map (renderStyle style{mode=OneLineMode} . ppPath)
+           (getStrPaths schema)
+     )
   where
     getStrPaths :: Schema Identity s c -> [Path]
     getStrPaths = collect CNil []
@@ -475,7 +479,7 @@ goV (CPar t)     rpath ss = restrictHead (reversePath rpath) t >> return ss
 ----------------------------------------------------------------------
 -- SeqSet
 
-type SeqSet   = Map.Map Sequence SeqId
+type SeqSet   = Map.Map [Symbol] 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,13 +508,11 @@ mapAccumL' f s (x:xs) = (s'',y:ys)
                               !(s'',ys) = mapAccumL' f s' xs
 
 addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
-addSequence seqs lst =
+addSequence seqs seq =
   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
 
 
 ------------------------------------------------------------

src/compiler/GF/Compile/GetGrammar.hs

@@ -50,20 +50,13 @@ getSourceModule opts file0 =
        Right (i,mi0) ->
          do liftIO $ removeTemp tmp
             let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
-                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') $
+            case renameEncoding `fmap` flag optEncoding (mflags mi0) of
+              Just coding' -> 
+                when (coding/=coding') $
                   raise $ "Encoding mismatch: "++coding++" /= "++coding'
                 where coding = maybe defaultEncoding renameEncoding optCoding
               _ -> return ()
-          --liftIO $ transcodeModule' (i,mi) -- old lexer
-            return (i,mi) -- new lexer
+            return (i,mi)
 
 getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
 getBNFCRules opts fpath = do

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -19,7 +19,7 @@ import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
 import GF.Infra.Option(Options,optionsPGF)
-import PGF.Internal(Literal(..))
+import PGF2.Internal(Literal(..))
 import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
 import System.FilePath ((</>), (<.>))
@@ -92,7 +92,7 @@ concrete2canonical gr cenv absname cnc modinfo =
         else let ((got,need),def) = paramType gr q
              in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
-toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
+-- toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
 toCanonical gr absname cenv (name,jment) =
   case jment of
     CncCat (Just (L loc typ)) _ _ pprn _ ->

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -1,17 +1,14 @@
-{-# LANGUAGE BangPatterns, FlexibleContexts #-}
-module GF.Compile.GrammarToPGF (mkCanon2pgf) where
+{-# LANGUAGE ImplicitParams, BangPatterns, FlexibleContexts, MagicHash #-}
+module GF.Compile.GrammarToPGF (grammar2PGF) where
 
---import GF.Compile.Export
 import GF.Compile.GeneratePMCFG
 import GF.Compile.GenerateBC
+import GF.Compile.OptimizePGF
 
-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 PGF2 hiding (mkType)
+import PGF2.Internal
 import GF.Grammar.Predef
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar hiding (Production)
 import qualified GF.Grammar.Lookup as Look
 import qualified GF.Grammar as A
 import qualified GF.Grammar.Macros as GM
@@ -22,111 +19,141 @@ 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)
 
-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))
+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)
   where
     cenv = resourceValues opts gr
+    aflags = err (const noOptions) mflags (lookupModule gr am)
 
-    mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
+    mkAbstr :: (?builder :: Builder s) => ModuleName -> Map.Map PGF2.Fun Double -> (AbsName, B s AbstrInfo)
+    mkAbstr am probs = (mi2i am, newAbstr flags cats funs)
       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 = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
+        flags = optionsPGF aflags
 
-        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | 
+        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))) |
                                    ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
-                                   let arity = mkArity ma mdef ty]
+                                   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)
 
-        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
+    mkConcr opts abs (cm,ex_seqs,cdefs) =
       let cflags = err (const noOptions) mflags (lookupModule gr cm)
           ciCmp | flag optCaseSensitive cflags = compare
-                | otherwise                    = C.compareCaseInsensitve
+                | otherwise                    = compareCaseInsensitive
 
-      (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)
+          flags = optionsPGF aflags
 
-      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
+          seqs = (mkSetArray . Set.fromList . concat) $
+                       (elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
 
           !(!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_arr ciCmp seqs cdefs fid_cnt1 cnccats
+                                = genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt1 cnccat_ranges
 
           printnames = genPrintNames cdefs
-      return (mi2i cm, D.Concr flags
-                              printnames
-                              cncfuns
-                              lindefs
-                              linrefs
-                              seqs
-                              productions
-                              IntMap.empty
-                              Map.empty
-                              cnccats
-                              IntMap.empty
-                              fid_cnt2)
+
+          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)
       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 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)
+        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)
 
-i2i :: Ident -> CId
-i2i = utf8CId . ident2utf8
+i2i :: Ident -> String
+i2i = showIdent
 
-mi2i :: ModuleName -> CId
+mi2i :: ModuleName -> String
 mi2i (MN i) = i2i i
 
-mkType :: [Ident] -> A.Type -> C.Type
+mkType :: (?builder :: Builder s) => [Ident] -> A.Type -> B s PGF2.Type
 mkType scope t =
   case GM.typeForm t of
     (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
-                           in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
+                           in dTyp hyps' (i2i cat) (map (mkExp scope') args)
 
-mkExp :: [Ident] -> A.Term -> C.Expr
-mkExp scope t = 
+mkExp :: (?builder :: Builder s) => [Ident] -> A.Term -> B s Expr
+mkExp scope t =
   case t of
-    Q (_,c)  -> C.EFun (i2i c)
-    QC (_,c) -> C.EFun (i2i c)
+    Q (_,c)  -> eFun (i2i c)
+    QC (_,c) -> eFun (i2i c)
     Vr x     -> case lookup x (zip scope [0..]) of
-                  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
-
+                  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
+{-
 mkPatt scope p = 
   case p of
     A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
@@ -141,67 +168,64 @@ 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 :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
+-}
+mkContext :: (?builder :: Builder s) => [Ident] -> A.Context -> ([Ident],[B s PGF2.Hypo])
 mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                       in if x == identW
-                                                           then (  scope,(bt,i2i x,ty'))
-                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps 
+                                                           then (  scope,hypo bt (i2i x) ty')
+                                                           else (x:scope,hypo bt (i2i x) ty')) scope hyps 
 
-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
+mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
+mkDef gr arity 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 =
-  let (index,cats) = mkCncCats 0 cdefs
-  in (index, Map.fromList cats)
+genCncCats gr am cm cdefs = mkCncCats 0 cdefs
   where
     mkCncCats index []                                                = (index,[])
     mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
       | id == cInt    = 
-            let cc            = pgfCncCat gr lincat fidInt
+            let cc            = pgfCncCat gr (i2i id) lincat fidInt
                 (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
+            in (index', cc : cats)
       | id == cFloat  = 
-            let cc            = pgfCncCat gr lincat fidFloat
+            let cc            = pgfCncCat gr (i2i id) lincat fidFloat
                 (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
+            in (index', cc : cats)
       | id == cString = 
-            let cc            = pgfCncCat gr lincat fidString
+            let cc            = pgfCncCat gr (i2i id) lincat fidString
                 (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
+            in (index', cc : cats)
       | otherwise     =
-            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
+            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
 
 genCncFuns :: Grammar
            -> ModuleName
            -> ModuleName
-           -> Array SeqId Sequence
-           -> (Sequence -> Sequence -> Ordering)
-           -> Array SeqId Sequence
+           -> Array SeqId [Symbol]
+           -> ([Symbol] -> [Symbol] -> Ordering)
+           -> Array SeqId [Symbol]
            -> [(QIdent, Info)]
            -> FId
-           -> Map.Map CId D.CncCat
+           -> Map.Map PGF2.Cat (Int,Int)
            -> (FId,
-               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 =
+               [(FId, [Production])],
+               [(FId, [FunId])],
+               [(FId, [FunId])],
+               [(PGF2.Fun,[SeqId])])
+genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccat_ranges =
   let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
-      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
-  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
+      (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)
   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
@@ -210,17 +234,16 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
           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 ---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)
+      let 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)
@@ -228,23 +251,23 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
     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 (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))
+    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))
           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 C.PArg (mkFId arg_C fid0)) ctxt)
+            [fid0] -> (st,map (flip PArg (mkFId arg_C fid0)) ctxt)
             fid0s  -> case Map.lookup fids crc of
-                        Just fid -> (st,map (flip C.PArg fid) ctxt)
+                        Just fid -> (st,map (flip PArg fid) ctxt)
                         Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
-                                        !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)
+                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map PCoerce fids)) prods
+                                    in ((fid_cnt+1,crc',prods'),map (flip PArg fid_cnt) ctxt)
           where
             (hargs_C,arg_C) = GM.catSkeleton ty
             ctxt = mapM (mkCtxt lindefs) hargs_C
@@ -252,14 +275,14 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
 
     mkLinDefId id = prefixIdent "lindef " id
 
-    toLinDef res offs lindefs (Production fid0 funid0 args) =
+    toLinDef res offs lindefs (A.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 (Production fid0 funid0 [fargs]) =
+    toLinRef res offs linrefs (A.Production fid0 funid0 [fargs]) =
       if fid0 == fidVar
         then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
         else linrefs
@@ -267,20 +290,20 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
         fids = map (mkFId res) fargs
 
     mkFId (_,cat) fid0 =
-      case Map.lookup (i2i cat) cnccats of
-        Just (C.CncCat s e _) -> s+fid0
-        Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
+      case Map.lookup (i2i cat) cnccat_ranges of
+        Just (s,e) -> s+fid0
+        Nothing    -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
 
     mkCtxt lindefs (_,cat) =
-      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"
+      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"
 
     toCncFun offs (m,id) funs (funid0,lins0) =
       let mseqs = case lookupModule gr m of
                     Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
                     _                              -> ex_seqs
-      in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs                                          
+      in (i2i id, map (newIndex mseqs) (elems lins0)):funs
       where
         newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
 
@@ -293,8 +316,9 @@ genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
           where
             k = (i+j) `div` 2
 
+
 genPrintNames cdefs =
-  Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
+  [(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]
@@ -306,3 +330,118 @@ 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

@@ -0,0 +1,189 @@
+{-# 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,13 +16,14 @@
 
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
-import PGF(showCId)
-import PGF.Internal
+import PGF2
+import PGF2.Internal
 
 import GF.Data.Operations
 import GF.Infra.Option
 
 import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
+import Data.Maybe(mapMaybe)
 import qualified Data.Map as Map
 
 type Prefix = String -> String
@@ -258,7 +259,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 +++ "(showCId i)" else "") ++++
+  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
   "      _ -> error (\"no" +++ cat ++ " \" ++ show t)"
    where
     isList = isListCat (cat,rules)
@@ -279,19 +280,22 @@ fInstance gId lexical m (cat,rules) =
 
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr =
-  (showCId (absname gr),
-   let fs =
-         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
-                                        fs@((_, (_,c)):_) <- fns]
-   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
+hSkeleton gr = 
+  (abstractName 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)]
   )
  where
-   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)
+   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
 {-
 updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
 updateSkeleton cat skel rule =

src/compiler/GF/Compile/PGFtoJS.hs

@@ -1,105 +0,0 @@
-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,156 +1,110 @@
 module GF.Compile.PGFtoJSON (pgf2json) where
 
-import PGF (showCId)
-import qualified PGF.Internal as M
-import PGF.Internal (
-  Abstr,
-  CId,
-  CncCat(..),
-  CncFun(..),
-  Concr,
-  DotPos,
-  Equation(..),
-  Literal(..),
-  PArg(..),
-  PGF,
-  Production(..),
-  Symbol(..),
-  Type,
-  absname,
-  abstract,
-  cflags,
-  cnccats,
-  cncfuns,
-  concretes,
-  funs,
-  productions,
-  sequences,
-  totalCats
-  )
-
-import qualified Text.JSON as JSON
-import Text.JSON (JSValue(..))
-
-import qualified Data.Array.IArray as Array
-import Data.Map (Map)
-import qualified Data.Set as Set
+import PGF2
+import PGF2.Internal
+import Text.JSON
 import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
 
 pgf2json :: PGF -> String
 pgf2json pgf =
-  JSON.encode $ JSON.makeObj
-    [ ("abstract", json_abstract)
-    , ("concretes", json_concretes)
-    ]
- where
-   n  = showCId $ absname pgf
-   as = abstract pgf
-   cs = Map.assocs (concretes pgf)
-   start = showCId $ M.lookStartCat pgf
-   json_abstract = abstract2json n start as
-   json_concretes = JSON.makeObj $ map concrete2json cs
-
-abstract2json :: String -> String -> Abstr -> JSValue
-abstract2json name start ds =
-  JSON.makeObj
-    [ ("name", mkJSStr name)
-    , ("startcat", mkJSStr start)
-    , ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds)))
+  encode $ makeObj
+    [ ("abstract", abstract2json pgf)
+    , ("concretes", makeObj $ map concrete2json
+                                (Map.toList (languages pgf)))
     ]
 
-absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue)
-absdef2json (f,(typ,_,_,_)) = (showCId f,sig)
+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)
   where
-    (args,cat) = M.catSkeleton typ
-    sig = JSON.makeObj
-      [ ("args", JSArray $ map (mkJSStr.showCId) args)
-      , ("cat", mkJSStr $ showCId cat)
+    Just (hypos,cat,_) = fmap unType (functionType pgf f)
+    sig = makeObj
+      [ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
+      , ("cat", showJSON cat)
       ]
 
 lit2json :: Literal -> JSValue
-lit2json (LStr s) = mkJSStr s
-lit2json (LInt n) = mkJSInt n
-lit2json (LFlt d) = JSRational True (toRational d)
+lit2json (LStr s) = showJSON s
+lit2json (LInt n) = showJSON n
+lit2json (LFlt d) = showJSON d
 
-concrete2json :: (CId,Concr) -> (String,JSValue)
-concrete2json (c,cnc) = (showCId c,obj)
+concrete2json :: (ConcName,Concr) -> (String,JSValue)
+concrete2json (c,cnc) = (c,obj)
   where
-    obj = JSON.makeObj
-      [ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ])
-      , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)])
-      , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc))))
-      , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc))))
-      , ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc)))
-      , ("totalfids", mkJSInt (totalCats cnc))
+    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))
       ]
 
-cats2json :: (CId, CncCat) -> (String,JSValue)
-cats2json (c,CncCat start end _) = (showCId c, ixs)
+cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
+cat2json (cat,start,end,_) = (cat, ixs)
   where
-    ixs = JSON.makeObj
-      [ ("start", mkJSInt start)
-      , ("end", mkJSInt end)
+    ixs = makeObj
+      [ ("start", showJSON start)
+      , ("end",   showJSON end)
       ]
 
 frule2json :: Production -> JSValue
 frule2json (PApply fid args) =
-  JSON.makeObj
-    [ ("type", mkJSStr "Apply")
-    , ("fid", mkJSInt fid)
-    , ("args", JSArray (map farg2json args))
+  makeObj
+    [ ("type", showJSON "Apply")
+    , ("fid",  showJSON fid)
+    , ("args", showJSON (map farg2json args))
     ]
 frule2json (PCoerce arg) =
-  JSON.makeObj
-    [ ("type", mkJSStr "Coerce")
-    , ("arg", mkJSInt arg)
+  makeObj
+    [ ("type", showJSON "Coerce")
+    , ("arg",  showJSON arg)
     ]
 
 farg2json :: PArg -> JSValue
 farg2json (PArg hypos fid) =
-  JSON.makeObj
-    [ ("type", mkJSStr "PArg")
-    , ("hypos", JSArray $ map (mkJSInt . snd) hypos)
-    , ("fid", mkJSInt fid)
+  makeObj
+    [ ("type", showJSON "PArg")
+    , ("hypos", JSArray $ map (showJSON . snd) hypos)
+    , ("fid", showJSON fid)
     ]
 
-ffun2json :: CncFun -> JSValue
-ffun2json (CncFun f lins) =
-  JSON.makeObj
-    [ ("name", mkJSStr $ showCId f)
-    , ("lins", JSArray (map mkJSInt (Array.elems lins)))
+ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
+ffun2json funid (fun,seqids) =
+  makeObj
+    [ ("name", showJSON fun)
+    , ("lins", showJSON seqids)
     ]
 
-seq2json :: Array.Array DotPos Symbol -> JSValue
-seq2json seq = JSArray [sym2json s | s <- Array.elems seq]
+seq2json :: SeqId -> [Symbol] -> JSValue
+seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
 
 sym2json :: Symbol -> JSValue
-sym2json (SymCat n l)    = new "SymCat" [mkJSInt n, mkJSInt l]
-sym2json (SymLit n l)    = new "SymLit" [mkJSInt n, mkJSInt l]
-sym2json (SymVar n l)    = new "SymVar" [mkJSInt n, mkJSInt l]
-sym2json (SymKS t)       = new "SymKS"  [mkJSStr t]
+sym2json (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 (SymKP ts alts) = new "SymKP"  [JSArray (map sym2json ts), JSArray (map alt2json alts)]
-sym2json SymBIND         = new "SymKS"  [mkJSStr "&+"]
-sym2json SymSOFT_BIND    = new "SymKS"  [mkJSStr "&+"]
-sym2json SymSOFT_SPACE   = new "SymKS"  [mkJSStr "&+"]
-sym2json SymCAPIT        = new "SymKS"  [mkJSStr "&|"]
-sym2json SymALL_CAPIT    = new "SymKS"  [mkJSStr "&|"]
+sym2json 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 SymNE           = new "SymNE"  []
 
 alt2json :: ([Symbol],[String]) -> JSValue
-alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)]
+alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
 
 new :: String -> [JSValue] -> JSValue
 new f xs =
-  JSON.makeObj
-    [ ("type", mkJSStr f)
-    , ("args", JSArray xs)
+  makeObj
+    [ ("type", showJSON f)
+    , ("args", showJSON 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 PGF
+import PGF2
 import Data.Maybe(maybe)
 import Data.List(intercalate)
 import GF.Infra.Option
@@ -24,9 +24,8 @@ javaPreamble name =
  ]
  
 javaMethod gr fun =
-  "  public static Expr "++name++"("++arg_decls++") { return new Expr("++show name++args++"); }"
+  "  public static Expr "++fun++"("++arg_decls++") { return new Expr("++show fun++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

@@ -1,262 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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

@@ -1,122 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.19 $
 --
@@ -23,9 +23,9 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.Rename (
-	       renameSourceTerm,
-	       renameModule
-	      ) where
+     renameSourceTerm,
+     renameModule
+    ) where
 
 import GF.Infra.Ident
 import GF.Infra.CheckM
@@ -68,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env)
 
 -- Fails immediately on error, makes it possible to try other possibilities
 renameIdentTerm' :: Status -> Term -> Check Term
-renameIdentTerm' env@(act,imps) t0 = 
+renameIdentTerm' env@(act,imps) t0 =
   case t0 of
     Vr c -> ident predefAbs c
     Cn c -> ident (\_ s -> checkError s) c
@@ -85,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 =
     _ -> return t0
   where
     opens   = [st  | (OSimple _,st) <- imps]
-    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ 
-              [(m, st) | (OQualif _ m, st) <- imps] ++ 
+    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
+              [(m, st) | (OQualif _ m, st) <- imps] ++
               [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
 
     -- this facility is mainly for BWC with GF1: you need not import PredefAbs
@@ -94,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 =
       | isPredefCat c = return (Q (cPredefAbs,c))
       | otherwise     = checkError s
 
-    ident alt c = 
+    ident alt c =
       case Map.lookup c act of
         Just f -> return (f c)
         _      -> case mapMaybe (Map.lookup c) opens of
@@ -157,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo))
 self2status :: ModuleName -> ModuleInfo -> StatusMap
 self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
 
-  
+
 renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
 renameInfo cwd status (m,mi) i info =
   case info of
@@ -208,7 +208,7 @@ renameTerm env vars = ren vars where
     Abs b x t    -> liftM  (Abs b x) (ren (x:vs) t)
     Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
     Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
-    Vr x      
+    Vr x
       | elem x vs -> return trm
       | otherwise -> renid trm
     Cn _   -> renid trm
@@ -219,7 +219,7 @@ renameTerm env vars = ren vars where
       i' <- case i of
         TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
         _ -> return i
-      liftM (T i') $ mapM (renCase vs) cs  
+      liftM (T i') $ mapM (renCase vs) cs
 
     Let (x,(m,a)) b -> do
       m' <- case m of
@@ -229,7 +229,7 @@ renameTerm env vars = ren vars where
       b' <- ren (x:vs) b
       return $ Let (x,(m',a')) b'
 
-    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either 
+    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either
                                                                -- record projection from variable or constant $r$ or qualified expression with module $r$
       | elem r vs -> return trm                                -- try var proj first ..
       | otherwise -> checks [ renid' (Q (MN r,label2ident l))      -- .. and qualified expression second.
@@ -331,7 +331,7 @@ renamePattern env patt =
 renameContext :: Status -> Context -> Check Context
 renameContext b = renc [] where
   renc vs cont = case cont of
-    (bt,x,t) : xts 
+    (bt,x,t) : xts
       | isWildIdent x -> do
           t'   <- ren vs t
           xts' <- renc vs xts

src/compiler/GF/Compile/ToAPI.hs

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

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/15 16:22:02 $ 
+-- > CVS $Date: 2005/09/15 16:22:02 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.16 $
 --
@@ -13,11 +13,11 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
-		  checkContext,
-		  checkTyp,
-		  checkDef,
-		  checkConstrs,
-		 ) where
+    checkContext,
+    checkTyp,
+    checkDef,
+    checkConstrs,
+   ) where
 
 import GF.Data.Operations
 
@@ -33,8 +33,8 @@ import GF.Text.Pretty
 --import Control.Monad (foldM, liftM, liftM2)
 
 -- | invariant way of creating TCEnv from context
-initTCEnv gamma = 
-  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) 
+initTCEnv gamma =
+  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
 
 -- interface to TC type checker
 

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

@@ -69,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
       lockRecType c t' ---- locking to be removed AR 20/6/2009
 
     _ | ty == typeTok -> return typeStr
-    _ | isPredefConstant ty -> return ty
 
     _ -> composOp (comp g) ty
 

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

@@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
   return ((l,ty):rs,mb_ty)
 
 -- | Invariant: if the third argument is (Just rho),
--- 	            then rho is in weak-prenex form
+--              then rho is in weak-prenex form
 instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
 instSigma ge scope t ty1 Nothing    = return (t,ty1)           -- INST1
 instSigma ge scope t ty1 (Just ty2) = do                       -- INST2
@@ -568,9 +568,9 @@ unifyVar ge scope i env vs ty2 = do            -- Check whether i is bound
     Bound ty1       -> do v <- liftErr (eval ge env ty1)
                           unify ge scope (vapply (geLoc ge) v vs) ty2
     Unbound scope' _ -> case value2term (geLoc ge) (scopeVars scope') ty2 of
-                          Left i     -> let (v,_) = reverse scope !! i
-                                        in tcError ("Variable" <+> pp v <+> "has escaped")
-                          Right ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
+                          -- Left i     -> let (v,_) = reverse scope !! i
+                          --               in tcError ("Variable" <+> pp v <+> "has escaped")
+                                ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
                                            if i `elem` ms2
                                              then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
                                                            nest 2 (ppTerm Unqualified 0 ty2'))
@@ -631,8 +631,8 @@ allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
 type Scope = [(Ident,Value)]
 
 type Sigma = Value
-type Rho   = Value	-- No top-level ForAll
-type Tau   = Value	-- No ForAlls anywhere
+type Rho   = Value -- No top-level ForAll
+type Tau   = Value -- No ForAlls anywhere
 
 data MetaValue
   = Unbound Scope Sigma
@@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do
     go (Vr tv)    acc = acc
     go (App x y)  acc = go x (go y acc)
     go (Meta i)   acc
-	  | i `elem` acc  = acc
-	  | otherwise	  = i : acc
+      | i `elem` acc  = acc
+      | otherwise     = i : acc
     go (Q _)      acc = acc
     go (QC _)     acc = acc
     go (Sort _)   acc = acc
@@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do
   return (foldr (go []) [] tys)
   where
     go bound (Vr tv)            acc
-	  | tv `elem` bound             = acc
-	  | tv `elem` acc               = acc
-	  | otherwise                   = tv : acc
+      | tv `elem` bound             = acc
+      | tv `elem` acc               = acc
+      | otherwise                   = tv : acc
     go bound (App x y)          acc = go bound x (go bound y acc)
     go bound (Meta _)           acc = acc
     go bound (Q _)              acc = acc
@@ -765,9 +765,9 @@ zonkTerm (Meta i) = do
 zonkTerm t = composOp zonkTerm t
 
 tc_value2term loc xs v =
-  case value2term loc xs v of
-    Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
-    Right t -> return t
+  return $ value2term loc xs v
+    -- Old value2term error message:
+    -- Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
 
 
 

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

@@ -5,21 +5,22 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/02 20:50:19 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.11 $
 --
 -- Thierry Coquand's type checking algorithm that creates a trace
 -----------------------------------------------------------------------------
 
-module GF.Compile.TypeCheck.TC (AExp(..),
-	   Theory,
-	   checkExp,
-	   inferExp,
-	   checkBranch,
-	   eqVal,
-	   whnf
-	  ) where
+module GF.Compile.TypeCheck.TC (
+    AExp(..),
+    Theory,
+    checkExp,
+    inferExp,
+    checkBranch,
+    eqVal,
+    whnf
+  ) where
 
 import GF.Data.Operations
 import GF.Grammar
@@ -31,17 +32,17 @@ import Data.Maybe
 import GF.Text.Pretty
 
 data AExp =
-     AVr   Ident Val 
+     AVr   Ident Val
    | ACn   QIdent Val
-   | AType 
-   | AInt  Int 
+   | AType
+   | AInt  Int
    | AFloat Double
    | AStr  String
    | AMeta MetaId Val
    | ALet  (Ident,(Val,AExp)) AExp
-   | AApp  AExp AExp Val 
-   | AAbs  Ident Val AExp 
-   | AProd Ident AExp AExp 
+   | AApp  AExp AExp Val
+   | AAbs  Ident Val AExp
+   | AProd Ident AExp AExp
 -- -- | AEqs  [([Exp],AExp)] --- not used
    | ARecType [ALabelling]
    | AR    [AAssign]
@@ -50,7 +51,7 @@ data AExp =
    | AData Val
   deriving (Eq,Show)
 
-type ALabelling = (Label, AExp) 
+type ALabelling = (Label, AExp)
 type AAssign = (Label, (Val, AExp))
 
 type Theory = QIdent -> Err Val
@@ -71,7 +72,7 @@ whnf :: Val -> Err Val
 whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
          case v of
   VApp u w -> do
-    u' <- whnf u 
+    u' <- whnf u
     w' <- whnf w
     app u' w'
   VClos env e -> eval env e
@@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val
 app u v = case u of
   VClos env (Abs _ x e) -> eval ((x,v):env) e
   _ -> return $ VApp u v
-  
+
 eval :: Env -> Term -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ 
+eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
              case e of
   Vr x    -> lookupVar env x
   Q c   -> return $ VCn c
@@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
   _ -> return $ VClos env e
 
 eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ 
+eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
                 do
   w1 <- whnf u1
-  w2 <- whnf u2 
+  w2 <- whnf u2
   let v = VGen k
   case (w1,w2) of
     (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
     (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
       eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
     (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
-      liftM2 (++) 
+      liftM2 (++)
         (eqVal k     (VClos            env1  a1) (VClos            env2  a2))
         (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
     (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
-    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] 
+    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
     --- thus ignore qualifications; valid because inheritance cannot
-    --- be qualified. Simplifies annotation. AR 17/3/2005 
+    --- be qualified. Simplifies annotation. AR 17/3/2005
     _ -> return [(w1,w2) | w1 /= w2]
 -- invariant: constraints are in whnf
 
@@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do
 
     Abs _ x t -> case typ of
       VClos env (Prod _ y a b) -> do
-	a' <- whnf $ VClos env a ---
-	(t',cs) <- checkExp th 
-                           (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
-	return (AAbs x a' t', cs)
+                           a' <- whnf $ VClos env a ---
+                           (t',cs) <- checkExp th
+                                          (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+                           return (AAbs x a' t', cs)
       _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
 
     Let (x, (mb_typ, e1)) e2 -> do
@@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
       (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
       return (AProd x a' b', csa ++ csb)
 
-    R xs -> 
+    R xs ->
       case typ of
         VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
                             [] -> return ()
@@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
   (e',w,cs1) <- inferExp th tenv e
   cs2 <- eqVal k w typ
   return (e',cs1 ++ cs2)
-      
+
 inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
 inferExp th tenv@(k,rho,gamma) e = case e of
    Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
@@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of
     (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
     return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
    App f t -> do
-    (f',w,csf) <- inferExp th tenv f 
+    (f',w,csf) <- inferExp th tenv f
     typ <- whnf w
     case typ of
       VClos env (Prod _ x a b) -> do
         (a',csa) <- checkExp th tenv t (VClos env a)
-	b' <- whnf $ VClos ((x,VClos rho t):env) b
-	return $ (AApp f' a' b', b', csf ++ csa)
+        b' <- whnf $ VClos ((x,VClos rho t):env) b
+        return $ (AApp f' a' b', b', csf ++ csa)
       _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
    _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
 
@@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
                    return ((lbl,(val,aexp)),cs)
 
 checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ 
-                                  chB tenv' ps' ty 
- where 
+checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
+                                  chB tenv' ps' ty
+ where
 
   (ps',_,rho2,k') = ps2ts k ps
   tenv' = (k, rho2++rho, gamma) ---- k' ?
@@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
       typ <- whnf ty
       case typ of
         VClos env (Prod _ y a b) -> do
-	  a' <- whnf $ VClos env a
+          a' <- whnf $ VClos env a
           (p', sigma, binds, cs1) <- checkP tenv p y a'
           let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
           ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
-	  return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
+          return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
         _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
     [] -> do
       (e,cs) <- checkExp th tenv t ty
@@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
      let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
      return (VClos sigma t, sigma, delta, cs)
 
-  ps2ts k = foldr p2t ([],0,[],k) 
+  ps2ts k = foldr p2t ([],0,[],k)
   p2t p (ps,i,g,k) = case p of
-     PW      -> (Meta i : ps, i+1,g,k) 
+     PW      -> (Meta i : ps, i+1,g,k)
      PV x    -> (Vr x   : ps, i, upd x k g,k+1)
      PAs x p -> p2t p (ps,i,g,k)
      PString s -> (K s : ps, i, g, k)
      PInt n -> (EInt n : ps, i, g, k)
      PFloat n -> (EFloat n : ps, i, g, k)
-     PP c xs -> (mkApp (Q c) xss : ps, j, g',k') 
+     PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
                     where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
      PImplArg p -> p2t p (ps,i,g,k)
      PTilde t -> (t : ps, i, g, k)
@@ -307,8 +308,8 @@ checkPatt th tenv exp val = do
        case typ of
          VClos env (Prod _ x a b) -> do
            (a',_,csa) <- checkExpP tenv t (VClos env a)
-	   b' <- whnf $ VClos ((x,VClos rho t):env) b
-	   return $ (AApp f' a' b', b', csf ++ csa)
+           b' <- whnf $ VClos ((x,VClos rho t):env) b
+           return $ (AApp f' a' b', b', csf ++ csa)
          _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
      _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
 
@@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
 mkAnnot a ti = do
   (v,cs) <- ti
   return (a v, v, cs)
-

src/compiler/GF/Compile/Update.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.8 $
 --
@@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I
 buildAnyTree m = go Map.empty
   where
     go map []         = return map
-    go map ((c,j):is) = do
+    go map ((c,j):is) =
       case Map.lookup c map of
         Just i  -> case unifyAnyInfo m i j of
-		     Ok k  -> go (Map.insert c k map) is
-		     Bad _ -> fail $ render ("conflicting information in module"<+>m $$
-		                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                             "and" $+$
-		                             nest 4 (ppJudgement Qualified (c,j)))
+          Ok k  -> go (Map.insert c k map) is
+          Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+                                  nest 4 (ppJudgement Qualified (c,i)) $$
+                                  "and" $+$
+                                  nest 4 (ppJudgement Qualified (c,j)))
         Nothing -> go (Map.insert c j map) is
 
 extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -51,14 +51,14 @@ extendModule cwd gr (name,m)
   ---- Should be replaced by real control. AR 4/2/2005
   | mstatus m == MSIncomplete && isModCnc m = return (name,m)
   | otherwise                               = checkInModule cwd m NoLoc empty $ do
-                                                 m' <- foldM extOne m (mextend m) 
+                                                 m' <- foldM extOne m (mextend m)
                                                  return (name,m')
  where
    extOne mo (n,cond) = do
      m0 <- lookupModule gr n
 
      -- test that the module types match, and find out if the old is complete
-     unless (sameMType (mtype m) (mtype mo)) 
+     unless (sameMType (mtype m) (mtype mo))
             (checkError ("illegal extension type to module" <+> name))
 
      let isCompl = isCompleteModule m0
@@ -67,7 +67,7 @@ extendModule cwd gr (name,m)
      js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
 
      -- if incomplete, throw away extension information
-     return $ 
+     return $
           if isCompl
             then mo {jments = js1}
             else mo {mextend= filter ((/=n) . fst) (mextend mo)
@@ -75,7 +75,7 @@ extendModule cwd gr (name,m)
                     ,jments = js1
                     }
 
--- | rebuilding instance + interface, and "with" modules, prior to renaming. 
+-- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
 rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
@@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
 
     -- add the information given in interface into an instance module
     Nothing -> do
-      unless (null is || mstatus mi == MSIncomplete) 
-             (checkError ("module" <+> i <+> 
+      unless (null is || mstatus mi == MSIncomplete)
+             (checkError ("module" <+> i <+>
                           "has open interfaces and must therefore be declared incomplete"))
       case mt of
         MTInstance (i0,mincl) -> do
@@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
       let stat' = if all (flip elem infs) is
                     then MSComplete
                     else MSIncomplete
-      unless (stat' == MSComplete || stat == MSIncomplete) 
+      unless (stat' == MSComplete || stat == MSIncomplete)
              (checkError ("module" <+> i <+> "remains incomplete"))
       ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
       let ops1 = nub $
@@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
 extendMod :: Grammar ->
              Bool -> (Module,Ident -> Bool) -> ModuleName ->
              Map.Map Ident Info -> Check (Map.Map Ident Info)
-extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) 
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
   where
     try new (c,i0)
       | not (cond c) = return new
       | otherwise    = case Map.lookup c new of
                          Just j -> case unifyAnyInfo name i j of
-		                     Ok k  -> return $ Map.insert c k new
-		                     Bad _ -> do (base,j) <- case j of 
-		                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
-		                                               _          -> return (base,j)
-		                                 (name,i) <- case i of 
+                                     Ok k  -> return $ Map.insert c k new
+                                     Bad _ -> do (base,j) <- case j of
+                                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
+                                                               _          -> return (base,j)
+                                                 (name,i) <- case i of
                                                                AnyInd _ m -> lookupOrigInfo gr (m,c)
                                                                _          -> return (name,i)
-		                                 checkError ("cannot unify the information" $$ 
-		                                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                                             "in module" <+> name <+> "with" $$
-		                                             nest 4 (ppJudgement Qualified (c,j)) $$
-		                                             "in module" <+> base)
+                                                 checkError ("cannot unify the information" $$
+                                                             nest 4 (ppJudgement Qualified (c,i)) $$
+                                                             "in module" <+> name <+> "with" $$
+                                                             nest 4 (ppJudgement Qualified (c,j)) $$
+                                                             "in module" <+> base)
                          Nothing-> if isCompl
                                      then return $ Map.insert c (indirInfo name i) new
                                      else return $ Map.insert c i new
@@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
         i = globalizeLoc (msrc mi) i0
 
     indirInfo :: ModuleName -> Info -> Info
-    indirInfo n info = AnyInd b n' where 
+    indirInfo n info = AnyInd b n' where
       (b,n') = case info of
         ResValue _ -> (True,n)
         ResParam _ _ -> (True,n)
-        AbsFun _ _ Nothing _ -> (True,n) 
+        AbsFun _ _ Nothing _ -> (True,n)
         AnyInd b k -> (b,k)
         _ -> (False,n) ---- canonical in Abs
 
@@ -194,24 +194,24 @@ globalizeLoc fpath i =
 
 unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
 unifyAnyInfo m i j = case (i,j) of
-  (AbsCat mc1, AbsCat mc2) -> 
+  (AbsCat mc1, AbsCat mc2) ->
     liftM AbsCat (unifyMaybeL mc1 mc2)
-  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> 
+  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
     liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
-  (ResValue (L l1 t1), ResValue (L l2 t2)) 
+  (ResValue (L l1 t1), ResValue (L l2 t2))
       | t1==t2    -> return (ResValue (L l1 t1))
       | otherwise -> fail ""
   (_, ResOverload ms t) | elem m ms ->
     return $ ResOverload ms t
-  (ResOper mt1 m1, ResOper mt2 m2) -> 
+  (ResOper mt1 m1, ResOper mt2 m2) ->
     liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
 
-  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> 
+  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
     liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2)  (unifyMaybe mpmcfg1 mpmcfg2)
-  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> 
+  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
     liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
 
   (AnyInd b1 m1, AnyInd b2 m2) -> do

src/compiler/GF/CompileInParallel.hs

@@ -1,6 +1,6 @@
 -- | Parallel grammar compilation
 module GF.CompileInParallel(parallelBatchCompile) where
-import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+import Prelude hiding (catch,(<>))
 import Control.Monad(join,ap,when,unless)
 import Control.Applicative
 import GF.Infra.Concurrency
@@ -36,11 +36,8 @@ import qualified Control.Monad.Fail as Fail
 parallelBatchCompile jobs opts rootfiles0 =
   do setJobs jobs
      rootfiles <- mapM canonical rootfiles0
-     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
+     lib_dir  <- canonical =<< getLibraryDirectory opts
+     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"

src/compiler/GF/Compiler.hs

@@ -1,8 +1,7 @@
-module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
 
-import PGF
-import PGF.Internal(concretes,optimizePGF,unionPGF)
-import PGF.Internal(putSplitAbs,encodeFile,runPut)
+import PGF2
+import PGF2.Internal(unionPGF,writePGF,writeConcr)
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -92,7 +91,7 @@ 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 'writePGF' and 'writeOutputs'.
+-- recreated. Calls 'writeGrammar' and 'writeOutputs'.
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -102,10 +101,8 @@ 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 pgf0 = foldl1 unionPGF pgfs
-                 probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf0
-                 let pgf = setProbabilities probs pgf0
-                 writePGF opts pgf
+                 let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
+                 writeGrammar opts pgf
                  writeOutputs opts pgf
 
 compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -115,12 +112,11 @@ compileCFFiles opts fs = do
   startCat <- case rules of
                 (Rule cat _ _ : _) -> return cat
                 _                  -> fail "empty CFG"
-  let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
+  probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
+  let pgf = cf2pgf opts (last fs) (mkCFG startCat Set.empty rules) probs
   unless (flag optStopAfterPhase opts == Compile) $
-     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'
+     do writeGrammar opts pgf
+        writeOutputs opts pgf
 
 unionPGFFiles :: Options -> [FilePath] -> IOE ()
 unionPGFFiles opts fs =
@@ -138,14 +134,11 @@ unionPGFFiles opts fs =
 
     doIt =
       do pgfs <- mapM readPGFVerbose fs
-         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")
+         let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
+         let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
          if pgfFile `elem` fs
            then putStrLnE $ "Refusing to overwrite " ++ pgfFile
-           else writePGF opts pgf
+           else writeGrammar opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -162,21 +155,20 @@ writeOutputs opts pgf = do
 -- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
 -- 'link') to a @.pgf@ file.
 -- A split PGF file is output if the @-split-pgf@ option is used.
-writePGF :: Options -> PGF -> IOE ()
-writePGF opts pgf =
-    if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
+writeGrammar :: Options -> PGF -> IOE ()
+writeGrammar opts pgf =
+  if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
   where
     writeNormalPGF =
        do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-          writing opts outfile $ encodeFile outfile pgf
+          writing opts outfile (writePGF outfile pgf)
 
     writeSplitPGF =
       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-         writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
-                                --encodeFile_ outfile (putSplitAbs pgf)
-         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
-           let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
-           writing opts outfile $ encodeFile outfile cnc
+         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)
 
 
 writeOutput :: Options -> FilePath-> String -> IOE ()
@@ -186,7 +178,7 @@ writeOutput opts file str = writing opts path $ writeUTF8File path str
 -- * Useful helper functions
 
 grammarName :: Options -> PGF -> String
-grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
+grammarName opts pgf = grammarName' opts (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

@@ -16,18 +16,18 @@
 {-# LANGUAGE CPP #-}
 module GF.Data.BacktrackM (
                     -- * the backtracking state monad
-		    BacktrackM,
-		    -- * monad specific utilities
-		    member,
-		    cut,
-		    -- * running the monad
-		    foldBM,          runBM,
-		    foldSolutions,   solutions,
-		    foldFinalStates, finalStates,
-		    
-		    -- * reexport the 'MonadState' class
-		    module Control.Monad.State.Class,
-		  ) where
+                    BacktrackM,
+                    -- * monad specific utilities
+                    member,
+                    cut,
+                    -- * running the monad
+                    foldBM,          runBM,
+                    foldSolutions,   solutions,
+                    foldFinalStates, finalStates,
+
+                    -- * reexport the 'MonadState' class
+                    module Control.Monad.State.Class,
+                  ) where
 
 import Data.List
 import Control.Applicative
@@ -70,7 +70,7 @@ instance Applicative (BacktrackM s) where
 instance Monad (BacktrackM s) where
     return a   = BM (\c s b -> c a s b)
     BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
-	where unBM (BM m) = m
+        where unBM (BM m) = m
 
 #if !(MIN_VERSION_base(4,13,0))
     fail = Fail.fail

src/compiler/GF/Data/Graph.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/10 16:43:44 $ 
+-- > CVS $Date: 2005/11/10 16:43:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.2 $
 --
@@ -34,7 +34,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 
 data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
-		 deriving (Eq,Show)
+    deriving (Eq,Show)
 
 type Node n a = (n,a)
 type Edge n b = (n,n,b)
@@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
 
 -- | Add a node to the graph.
 newNode :: a               -- ^ Node label
-        -> Graph n a b 
+        -> Graph n a b
         -> (Graph n a b,n) -- ^ Node graph and name of new node
 newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
 
@@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es
 -- lazy version:
 -- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
 
-insertEdgeWith :: Eq n => 
+insertEdgeWith :: Eq n =>
                   (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
 insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
   where h [] = [e]
@@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n)
 -- | Remove a set of nodes and all edges to and from those nodes.
 removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
 removeNodes xs (Graph c ns es) = Graph c ns' es'
-  where 
+  where
   keepNode n = not (Set.member n xs)
   ns' = [ x | x@(n,_) <- ns, keepNode n ]
   es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
@@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es'
 -- | Get a map of node names to info about each node.
 nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
 nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
-  where 
+  where
   inc = groupEdgesBy edgeTo g
   out = groupEdgesBy edgeFrom g
   fn m n = fromMaybe [] (Map.lookup n m)
@@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b
 reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
 
 -- | Add the nodes from the second graph to the first graph.
---   The nodes in the second graph will be renamed using the name 
+--   The nodes in the second graph will be renamed using the name
 --   supply in the first graph.
 --   This function is more efficient when the second graph
 --   is smaller than the first.
-mergeGraphs :: Ord m => Graph n a b -> Graph m a b 
+mergeGraphs :: Ord m => Graph n a b -> Graph m a b
             -> (Graph n a b, m -> n) -- ^ The new graph and a function translating
                                       --  the old names of nodes in the second graph
                                       --  to names in the new graph.
 mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
-  where 
+  where
   (xs,c') = splitAt (length (nodes g2)) c
   newNames = Map.fromList (zip (map fst (nodes g2)) xs)
   newName n = fromJust $ Map.lookup n newNames
@@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function
             -> Graph n a b -> Graph m a b
 renameNodes newName c (Graph _ ns es) = Graph c ns' es'
     where ns' = map' (\ (n,x) -> (newName n,x)) ns
-	  es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
+          es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
 
 -- | A strict 'map'
 map' :: (a -> b) -> [a] -> [b]

src/compiler/GF/Data/Graphviz.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/15 18:10:44 $ 
+-- > CVS $Date: 2005/09/15 18:10:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.2 $
 --
@@ -13,14 +13,14 @@
 -----------------------------------------------------------------------------
 
 module GF.Data.Graphviz (
-				  Graph(..), GraphType(..), 
-				  Node(..), Edge(..),
-				  Attr,
-                                  addSubGraphs,
-                                  setName,
-                                  setAttr,
-				  prGraphviz
-			) where
+                          Graph(..), GraphType(..),
+                          Node(..), Edge(..),
+                          Attr,
+                          addSubGraphs,
+                          setName,
+                          setAttr,
+                          prGraphviz
+                        ) where
 
 import Data.Char
 
@@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) =
     graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
 
 prSubGraph :: Graph -> String
-prSubGraph g@(Graph _ i _ _ _ _) = 
+prSubGraph g@(Graph _ i _ _ _ _) =
     "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
 
 prGraph :: Graph -> String
-prGraph (Graph t id at ns es ss) = 
+prGraph (Graph t id at ns es ss) =
     unlines $ map (++";") (map prAttr at
-		           ++ map prNode ns 
-		           ++ map (prEdge t) es
+                           ++ map prNode ns
+                           ++ map (prEdge t) es
                            ++ map prSubGraph ss)
 
 graphtype :: GraphType -> String
@@ -96,7 +96,7 @@ edgeop Undirected = "--"
 
 prAttrList :: [Attr] -> String
 prAttrList [] = ""
-prAttrList at =	"[" ++ join "," (map prAttr at) ++ "]"
+prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
 
 prAttr :: Attr -> String
 prAttr (n,v) = esc n ++ " = " ++ esc v

src/compiler/GF/Data/Operations.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/11 16:12:41 $ 
+-- > CVS $Date: 2005/11/11 16:12:41 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.22 $
 --
@@ -15,34 +15,34 @@
 -----------------------------------------------------------------------------
 
 module GF.Data.Operations (
-		   -- ** The Error monad
-		   Err(..), err, maybeErr, testErr, fromErr, errIn, 
-		   lookupErr,
+     -- ** The Error monad
+     Err(..), err, maybeErr, testErr, fromErr, errIn,
+     lookupErr,
 
-		   -- ** Error monad class
-		   ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
-                   liftErr,
-		   
-		   -- ** Checking
-		   checkUnique, unifyMaybeBy, unifyMaybe,
+     -- ** Error monad class
+     ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
+                 liftErr,
 
-           -- ** Monadic operations on lists and pairs
-		   mapPairsM, pairM,
- 
-		   -- ** Printing
-		   indent, (+++), (++-), (++++), (+++-), (+++++),
-		   prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, 
-		   prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
-		   numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+     -- ** Checking
+     checkUnique, unifyMaybeBy, unifyMaybe,
 
-		   -- ** Topological sorting
-		   topoTest, topoTest2,
+         -- ** Monadic operations on lists and pairs
+     mapPairsM, pairM,
 
-		   -- ** Misc
-		   readIntArg,
-		   iterFix,  chunks,
-                
-		  ) where
+     -- ** Printing
+     indent, (+++), (++-), (++++), (+++-), (+++++),
+     prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
+     prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+     numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+
+     -- ** Topological sorting
+     topoTest, topoTest2,
+
+     -- ** Misc
+     readIntArg,
+     iterFix,  chunks,
+
+    ) where
 
 import Data.Char (isSpace, toUpper, isSpace, isDigit)
 import Data.List (nub, partition, (\\))
@@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s
 (+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
 a +++ b   = a ++ " "    ++ b
 
-a ++- ""  = a 
+a ++- ""  = a
 a ++- b   = a +++ b
 
 a ++++ b  = a ++ "\n"   ++ b
@@ -145,20 +145,20 @@ prCurly   s = "{" ++ s ++ "}"
 prBracket s = "[" ++ s ++ "]"
 
 prArgList, prSemicList, prCurlyList :: [String] -> String
-prArgList   = prParenth . prTList "," 
+prArgList   = prParenth . prTList ","
 prSemicList = prTList " ; "
 prCurlyList = prCurly . prSemicList
 
 restoreEscapes :: String -> String
-restoreEscapes s = 
-  case s of 
+restoreEscapes s =
+  case s of
     []       -> []
     '"' : t  -> '\\' : '"'  : restoreEscapes t
     '\\': t  -> '\\' : '\\' : restoreEscapes t
     c   : t  -> c : restoreEscapes t
 
 numberedParagraphs :: [[String]] -> [String]
-numberedParagraphs t = case t of 
+numberedParagraphs t = case t of
   []   -> []
   p:[] -> p
   _    -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
@@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
         ([],[]) -> Just []
         ([],_) -> Nothing
         (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
-	  where leaves = map fst ns
+            where leaves = map fst ns
 
 
 -- | Fix point iterator (for computing e.g. transitive closures or reachability)
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
-iterFix more start = iter start start 
+iterFix more start = iter start start
   where
     iter old new = if (null new')
                       then old
@@ -241,7 +241,7 @@ liftErr e = err raise return e
 {-
 instance ErrorMonad (STM s) where
   raise msg = STM (\s -> raise msg)
-  handle (STM f) g = STM (\s -> (f s) 
+  handle (STM f) g = STM (\s -> (f s)
                                 `handle` (\e -> let STM g' = (g e) in
                                                     g' s))
 

src/compiler/GF/Data/Relation.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/26 17:13:13 $ 
+-- > CVS $Date: 2005/10/26 17:13:13 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.1 $
 --
@@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r
   where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
 
 reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
-		 -> Rel a -> Rel a
+                  -> Rel a -> Rel a
 reflexiveClosure_ u r = relates [(x,x) | x <- u] r
 
 -- | Uses 'domain'
@@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a
 reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
 
 -- | Keep the related pairs for which the predicate is true.
-filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a 
+filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
 filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
 
 -- | Remove keys that map to no elements.
@@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
 purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
                 in (r', Map.keysSet r'')
 
--- | Get the equivalence classes from an equivalence relation. 
+-- | Get the equivalence classes from an equivalence relation.
 equivalenceClasses :: Ord a => Rel a -> [Set a]
 equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
  where equivalenceClasses_ [] _ = []
        equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
-	   where ys = allRelated r x
-                 zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+          where ys = allRelated r x
+                zs = [x' | x' <- xs, not (x' `Set.member` ys)]
 
 isTransitive :: Ord a => Rel a -> Bool
-isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, 
+isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
                       y <- Set.toList ys, z <- Set.toList (allRelated r y)]
 
 isReflexive :: Ord a => Rel a -> Bool
@@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
                    Nothing      -> (r', Set.empty, Set.empty)
                    -- remove element from all incoming and outgoing sets
                    -- of other elements
-                   Just (is,os) -> 
+                   Just (is,os) ->
                        let r''  = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r'  $ Set.toList is
                            r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
                         in (r''', is, os)
@@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a
 incoming x r = maybe Set.empty fst $ Map.lookup x r
 
 --outgoing :: Ord a => a -> Rel' a -> Set a
---outgoing x r = maybe Set.empty snd $ Map.lookup x r
+--outgoing x r = maybe Set.empty snd $ Map.lookup x r

src/compiler/GF/Data/Utilities.hs

@@ -4,7 +4,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/26 18:47:16 $ 
+-- > CVS $Date: 2005/10/26 18:47:16 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.6 $
 --
@@ -33,7 +33,7 @@ longerThan    n = not . notLongerThan n
 lookupList :: Eq a => a -> [(a, b)] -> [b]
 lookupList a [] = []
 lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
-		    | otherwise  =         lookupList a ps
+                    | otherwise  =         lookupList a ps
 
 split :: [a] -> ([a], [a])
 split (x : y : as) = (x:xs, y:ys)
@@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
 foldMerge :: (a -> a -> a) -> a -> [a] -> a
 foldMerge merge zero = fm
     where fm [] = zero
-	  fm [a] = a
-	  fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+          fm [a] = a
+          fm abs = let (as, bs) = split abs in fm as `merge` fm bs
 
 select :: [a] -> [(a, [a])]
 select [] = []
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
 safeInit [] = []
 safeInit xs = init xs
 
--- | Sorts and then groups elements given an ordering of the 
+-- | Sorts and then groups elements given an ordering of the
 --   elements.
 sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
 sortGroupBy f = groupBy (compareEq f) . sortBy f

src/compiler/GF/Grammar/BNFC.hs

@@ -15,7 +15,6 @@
 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
@@ -64,12 +63,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 (mkCId $ "coercion_" ++ c) []
+                        rn = CFObj ("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 (mkCId $ "coercion_" ++ c') []
+         rn = CFObj ("coercion_" ++ c') []
 
 transformSymb :: SepMap -> BNFCSymbol -> (String, ParamCFSymbol)
 transformSymb sepMap s = case s of
@@ -94,7 +93,7 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
                        then [NonTerminal (c,[0]) | ne]
                        else [NonTerminal (c,[0]) | ne] ++
                             [Terminal symb | symb /= "" && ne]
-                rn   = CFObj (mkCId $ "Base" ++ c) []
+                rn   = CFObj ("Base" ++ c) []
         ruleCons
           | isSep && symb /= "" && not ne = [Rule ("List" ++ c,[1]) smbs0 rn
                                             ,Rule ("List" ++ c,[1]) smbs1 rn]
@@ -107,4 +106,4 @@ createListRules' ne isSep symb c = ruleBase : ruleCons
                 smbs = [NonTerminal (c,[0])] ++
                        [Terminal symb | symb /= ""] ++
                        [NonTerminal ("List" ++ c,[0])]
-                rn   = CFObj (mkCId $ "Cons" ++ c) []
+                rn   = CFObj ("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 PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
+import Data.Binary
 import qualified Data.Map as Map(empty)
 import qualified Data.ByteString.Char8 as BS
 
@@ -22,8 +22,7 @@ import GF.Infra.Option
 import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
-import PGF() -- Binary instances
-import PGF.Internal(Literal(..))
+import PGF2.Internal(Literal(..),Symbol(..))
 
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF04"
@@ -298,6 +297,53 @@ 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,10 +4,11 @@
 --
 -- Context-free grammar representation and manipulation.
 ----------------------------------------------------------------------
-module GF.Grammar.CFG where
+module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
 
 import GF.Data.Utilities
-import PGF
+import PGF2(Fun,Cat)
+import PGF2.Internal(Token)
 import GF.Data.Relation
 
 import Data.Map (Map)
@@ -20,8 +21,6 @@ import qualified Data.Set as Set
 -- * Types
 --
 
-type Cat = String
-
 data Symbol c t = NonTerminal c | Terminal t
   deriving (Eq, Ord, Show)
 
@@ -39,12 +38,12 @@ data Grammar c t = Grammar {
   deriving (Eq, Ord, Show)
 
 data CFTerm
-    = CFObj CId [CFTerm] -- ^ an abstract syntax function with arguments
+    = CFObj Fun [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 CId -- ^ A metavariable
+    | CFMeta Fun -- ^ A metavariable
   deriving (Eq, Ord, Show)
 
 type CFSymbol = Symbol  Cat Token
@@ -232,7 +231,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'=mkCId (showCId fun++suffix),
+                          let fun'=fun++suffix,
                           not (fun' `Set.member` funs)]
 
 -- | Gets all rules in a CFG.
@@ -310,12 +309,12 @@ prProductions prods =
 prCFTerm :: CFTerm -> String
 prCFTerm = pr 0
   where
-    pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
+    pr p (CFObj f args) = paren p (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) = "?" ++ showCId c
+    pr _ (CFMeta c) = "?" ++ c
     paren 0 x = x
     paren 1 x = "(" ++ x ++ ")"
 
@@ -323,12 +322,12 @@ prCFTerm = pr 0
 -- * CFRule Utilities
 --
 
-ruleFun :: Rule c t -> CId
+ruleFun :: Rule c t -> Fun
 ruleFun (Rule _ _ t) = f t
   where f (CFObj n _) = n
         f (CFApp _ x) = f x
         f (CFAbs _ x) = f x
-        f _ = mkCId ""
+        f _ = ""
 
 -- | Check if any of the categories used on the right-hand side
 --   are in the given list of categories.
@@ -336,7 +335,7 @@ anyUsedBy :: Eq c => [c] -> Rule c t -> Bool
 anyUsedBy cs (Rule _ ss _) = any (`elem` cs) (filterCats ss)
 
 mkCFTerm :: String -> CFTerm
-mkCFTerm n = CFObj (mkCId n) []
+mkCFTerm n = CFObj n []
 
 ruleIsNonRecursive :: Ord c => Set c -> Rule c t -> Bool
 ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs

src/compiler/GF/Grammar/Canonical.hs

@@ -45,12 +45,12 @@ data LincatDef = LincatDef CatId LinType  deriving Show
 data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
 
 -- | Linearization type, RHS of @lincat@
-data LinType = FloatType 
-             | IntType 
+data LinType = FloatType
+             | IntType
              | ParamType ParamType
              | RecordType [RecordRowType]
-             | StrType 
-             | TableType LinType LinType 
+             | StrType
+             | TableType LinType LinType
              | TupleType [LinType]
               deriving (Eq,Ord,Show)
 
@@ -60,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 data LinValue = ConcatValue LinValue LinValue
               | LiteralValue LinLiteral
               | ErrorValue String
-              | ParamConstant ParamValue 
+              | ParamConstant ParamValue
               | PredefValue PredefId
               | RecordValue [RecordRowValue]
               | TableValue LinType [TableRowValue]
@@ -74,9 +74,9 @@ data LinValue = ConcatValue LinValue LinValue
               | CommentedValue String LinValue
               deriving (Eq,Ord,Show)
 
-data LinLiteral = FloatConstant Float 
-                | IntConstant Int 
-                | StrConstant String 
+data LinLiteral = FloatConstant Float
+                | IntConstant Int
+                | StrConstant String
                 deriving (Eq,Ord,Show)
 
 data LinPattern = ParamPattern ParamPattern
@@ -107,7 +107,7 @@ newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
 newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
 data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
 
--- | Name of param type or param value 
+-- | Name of param type or param value
 newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
@@ -250,7 +250,7 @@ instance PPA LinLiteral where
             FloatConstant f -> pp f
             IntConstant n -> pp n
             StrConstant s -> doubleQuotes s -- hmm
-  
+
 instance RhsSeparator LinValue where rhsSep _ = pp "="
 
 instance Pretty LinPattern where
@@ -265,7 +265,7 @@ instance PPA LinPattern where
       ParamPattern pv -> ppA pv
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"                
+      WildPattern     -> pp "_"
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="
 

src/compiler/GF/Grammar/EBNF.hs

@@ -16,7 +16,6 @@ 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)
@@ -40,7 +39,7 @@ ebnf2cf :: EBNF -> [ParamCFRule]
 ebnf2cf ebnf = 
   [Rule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)]
   where
-    mkCFF i (c,_) = CFObj (mkCId ("Mk" ++ c ++ "_" ++ show i)) []
+    mkCFF i (c,_) = CFObj ("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, Sequence
+        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
         ) where
 
 import GF.Infra.Ident
@@ -73,7 +73,8 @@ import GF.Infra.Location
 
 import GF.Data.Operations
 
-import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
+import PGF2(BindType(..))
+import PGF2.Internal(FId, FunId, SeqId, LIndex, Symbol)
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -99,7 +100,7 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Array SeqId Sequence),
+    mseqs   :: Maybe (Array SeqId [Symbol]),
     jments  :: Map.Map Ident Info
   }
 

src/compiler/GF/Grammar/Lexer.x

@@ -267,7 +267,7 @@ type AlexInput2 = (AlexInput,AlexInput)
 
 data ParseResult a
   = POk AlexInput2 a
-  | PFailed Posn	-- The position of the error
+  | PFailed Posn        -- The position of the error
             String      -- The error message
 
 newtype P a = P { unP :: AlexInput2 -> ParseResult a }

src/compiler/GF/Grammar/Lookup.hs

@@ -6,7 +6,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/27 13:21:53 $ 
+-- > CVS $Date: 2005/10/27 13:21:53 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.15 $
 --
@@ -20,17 +20,17 @@ module GF.Grammar.Lookup (
            lookupOrigInfo,
            allOrigInfos,
            lookupResDef, lookupResDefLoc,
-           lookupResType, 
+           lookupResType,
            lookupOverload,
            lookupOverloadTypes,
-           lookupParamValues, 
+           lookupParamValues,
            allParamValues,
-           lookupAbsDef, 
-           lookupLincat, 
+           lookupAbsDef,
+           lookupLincat,
            lookupFunType,
            lookupCatContext,
            allOpers, allOpersTo
-	      ) where
+          ) where
 
 import GF.Data.Operations
 import GF.Infra.Ident
@@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
 lookupResDefLoc gr (m,c)
   | isPredefCat c = fmap noLoc (lock c defLinType)
   | otherwise     = look m c
-  where 
+  where
     look m c = do
       info <- lookupQIdentInfo gr (m,c)
       case info of
@@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c)
         ResOper _ Nothing  -> return (noLoc (Q (m,c)))
         CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
         CncCat _ _ _ _ _         -> fmap noLoc (lock c defLinType)
-      
+
         CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
         CncFun _                (Just ltr) _ _ -> return ltr
 
@@ -95,7 +95,7 @@ lookupResType gr (m,c) = do
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
     CncFun (Just (cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val 
+          val' <- lock cat val
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _      -> return typePType
@@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do
     -- used in reused concrete
     CncCat _ _ _ _ _ -> ret typeType
     CncFun (Just (cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val 
+          val' <- lock cat val
           ret $ mkProd cont val' []
     ResParam _ _      -> ret typePType
     ResValue (L _ t)  -> ret t
@@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do
     case info of
       ResOverload os tysts -> do
             tss <- mapM (\x -> lookupOverload gr (x,c)) os
-            return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | 
-                      (L _ ty,L _ tr) <- tysts] ++ 
+            return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
+                      (L _ ty,L _ tr) <- tysts] ++
                      concat tss
 
       AnyInd _ n  -> lookupOverload gr (n,c)
@@ -216,7 +216,7 @@ lookupCatContext gr m c = do
 -- notice that it only gives the modules that are reachable and the opers that are included
 
 allOpers :: Grammar -> [(QIdent,Type,Location)]
-allOpers gr = 
+allOpers gr =
   [((m,op),typ,loc) |
       (m,mi)  <- maybe [] (allExtends gr) (greatestResource gr),
       (op,info)  <- Map.toList (jments mi),

src/compiler/GF/Grammar/Parser.y

@@ -25,7 +25,6 @@ import GF.Compile.Update (buildAnyTree)
 import Data.List(intersperse)
 import Data.Char(isAlphaNum)
 import qualified Data.Map as Map
-import PGF(mkCId)
 
 }
 
@@ -625,7 +624,7 @@ ListCFRule
 
 CFRule :: { [BNFCRule] }
 CFRule
-  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
+  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
                                            }
   | Ident '::=' ListCFRHS ';'              { let { cat = showIdent $1;
                                                    mkFun cat its =
@@ -638,7 +637,7 @@ CFRule
                                                        Terminal    c     -> filter isAlphaNum c;
                                                        NonTerminal (t,_) -> t
                                                      }
-                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
+                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
                                            }
   | 'coercions' Ident Integer ';'          { [BNFCCoercions (showIdent $2) $3]}
   | 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }

src/compiler/GF/Grammar/PatternMatch.hs

@@ -5,18 +5,19 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/12 12:38:29 $ 
+-- > CVS $Date: 2005/10/12 12:38:29 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.7 $
 --
 -- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
 -----------------------------------------------------------------------------
 
-module GF.Grammar.PatternMatch (matchPattern,
-		     testOvershadow, 
-		     findMatch,
-                     measurePatt
-		    ) where
+module GF.Grammar.PatternMatch (
+                                matchPattern,
+                                testOvershadow,
+                                findMatch,
+                                measurePatt
+                               ) where
 
 import GF.Data.Operations
 import GF.Grammar.Grammar
@@ -30,7 +31,7 @@ import GF.Text.Pretty
 --import Debug.Trace
 
 matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
-matchPattern pts term = 
+matchPattern pts term =
   if not (isInConstantForm term)
     then raise (render ("variables occur in" <+> pp term))
   else do
@@ -61,15 +62,15 @@ testOvershadow pts vs = do
 findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
 findMatch cases terms = case cases of
    [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
-   (patts,_):_ | length patts /= length terms -> 
-       raise (render ("wrong number of args for patterns :" <+> hsep patts <+> 
+   (patts,_):_ | length patts /= length terms ->
+       raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
                     "cannot take" <+> hsep terms))
    (patts,val):cc -> case mapM tryMatch (zip patts terms) of
        Ok substs -> return (val, concat substs)
        _         -> findMatch cc terms
 
 tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do 
+tryMatch (p,t) = do
   t' <- termForm t
   trym p t'
  where
@@ -83,26 +84,26 @@ tryMatch (p,t) = do
       (PString s, ([],K i,[])) | s==i -> return []
       (PInt s, ([],EInt i,[])) | s==i -> return []
       (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
-      (PC p pp, ([], Con f, tt)) | 
+      (PC p pp, ([], Con f, tt)) |
             p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
 
-      (PP (q,p) pp, ([], QC (r,f), tt)) | 
+      (PP (q,p) pp, ([], QC (r,f), tt)) |
             -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
             p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
       ---- hack for AppPredef bug
-      (PP (q,p) pp, ([], Q (r,f), tt)) | 
-            -- q `eqStrIdent` r && --- 
+      (PP (q,p) pp, ([], Q (r,f), tt)) |
+            -- q `eqStrIdent` r && ---
             p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
 
       (PR r, ([],R r',[])) |
             all (`elem` map fst r') (map fst r) ->
-         do matches <- mapM tryMatch 
+         do matches <- mapM tryMatch
                             [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
             return (concat matches)
       (PT _ p',_) -> trym p' t'
@@ -125,7 +126,7 @@ tryMatch (p,t) = do
       (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
 
       (PRep p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq p1)) (PString "") 
+         trym (foldr (const (PSeq p1)) (PString "")
            [1..n]) t' | n <- [0 .. length s]
         ] >>
         return []

src/compiler/GF/Grammar/Printer.hs

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

@@ -5,22 +5,23 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:32 $ 
+-- > CVS $Date: 2005/04/21 16:22:32 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.7 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
 
-module GF.Grammar.Values (-- ** Values used in TC type checking
-	       Val(..), Env,
-	       -- ** Annotated tree used in editing
+module GF.Grammar.Values (
+               -- ** Values used in TC type checking
+               Val(..), Env,
+               -- ** Annotated tree used in editing
                Binds, Constraints, MetaSubst,
-	       -- ** For TC
-	       valAbsInt, valAbsFloat, valAbsString, vType,
-	       isPredefCat,
-	       eType, 
-	      ) where
+               -- ** For TC
+               valAbsInt, valAbsFloat, valAbsString, vType,
+               isPredefCat,
+               eType,
+              ) where
 
 import GF.Infra.Ident
 import GF.Grammar.Grammar

src/compiler/GF/Infra/BuildInfo.hs

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

src/compiler/GF/Infra/CheckM.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:33 $ 
+-- > CVS $Date: 2005/04/21 16:22:33 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.5 $
 --
@@ -14,12 +14,12 @@
 
 module GF.Infra.CheckM
           (Check, CheckResult, Message, runCheck, runCheck',
-	   checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
-	   checkIn, checkInModule, checkMap, checkMapRecover,
+           checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
+           checkIn, checkInModule, checkMap, checkMapRecover,
            parallelCheck, accumulateError, commitCheck,
-	  ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+          ) where
 
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import GF.Data.Operations
 --import GF.Infra.Ident
 --import GF.Grammar.Grammar(msrc) -- ,Context
@@ -141,10 +141,10 @@ checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
   where f' (k,v) = fmap ((,)k) (f k v)
 
 {-
-checkMapRecover f mp = do 
+checkMapRecover f mp = do
   let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
   case [s | (_,Bad s) <- xs] of
-    ss@(_:_) -> checkError (text (unlines ss)) 
+    ss@(_:_) -> checkError (text (unlines ss))
     _   -> do
       let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
       if not (all null ss) then checkWarn (text (unlines ss)) else return ()

src/compiler/GF/Infra/Ident.hs

@@ -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 PGF.Internal(Binary(..))
+import Data.Binary(Binary(..))
 import GF.Text.Pretty
 
 

src/compiler/GF/Infra/Location.hs

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

src/compiler/GF/Infra/Option.hs

@@ -34,16 +34,14 @@ import Data.Maybe
 import GF.Infra.Ident
 import GF.Infra.GetOpt
 import GF.Grammar.Predef
---import System.Console.GetOpt
 import System.FilePath
---import System.IO
+import PGF2.Internal(Literal(..))
 
 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
@@ -76,7 +74,6 @@ errors = raise . unlines
 
 data Mode = ModeVersion | ModeHelp
           | ModeInteractive | ModeRun
-          | ModeInteractive2 | ModeRun2
           | ModeCompiler
           | ModeServer {-port::-}Int
   deriving (Show,Eq,Ord)
@@ -95,7 +92,6 @@ data OutputFormat = FmtPGFPretty
                   | FmtPython
                   | FmtHaskell
                   | FmtJava
-                  | FmtProlog
                   | FmtBNF
                   | FmtEBNF
                   | FmtRegular
@@ -162,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,
@@ -217,10 +213,9 @@ parseModuleOptions args = do
     then return opts
     else errors $ map ("Non-option among module options: " ++) nonopts
 
-fixRelativeLibPaths curr_dir lib_dirs (Options o) = Options (fixPathFlags . o)
+fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
   where
-    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [parent </> dir
-                                                                                      | parent <- curr_dir : lib_dirs]) path}
+    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
 
 -- Showing options
 
@@ -316,8 +311,6 @@ 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")
@@ -432,7 +425,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 $ splitInModuleSearchPath x }
+       gfLibPath   x = set $ \o -> o { optGFLibPath = Just x }
        gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
@@ -480,12 +473,9 @@ outputFormatsExpl =
     [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
      (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
-     (("js",           FmtJavaScript),"JavaScript (whole grammar)"),
      (("json",         FmtJSON),"JSON (whole grammar)"),
-     (("python",       FmtPython),"Python (whole grammar)"),
      (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
      (("java",         FmtJava),"Java (abstract syntax)"),
-     (("prolog",       FmtProlog),"Prolog (whole grammar)"),
      (("bnf",          FmtBNF),"BNF (context-free grammar)"),
      (("ebnf",         FmtEBNF),"Extended BNF"),
      (("regular",      FmtRegular),"* regular grammar"),

src/compiler/GF/Infra/SIO.hs

@@ -12,9 +12,6 @@ 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
@@ -39,9 +36,6 @@ 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
@@ -127,7 +121,3 @@ 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,7 +38,6 @@ 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
@@ -52,32 +51,28 @@ 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   -> liftM splitSearchPath $ liftIO (catch (getEnv gfLibraryPath)
-                                                (\ex -> fmap (</> "lib") getDataDir))
+    Nothing   -> liftIO $ catch (getEnv gfLibraryPath)
+                                (\ex -> fmap (</> "lib") getDataDir)
 
-getGrammarPath :: MonadIO io => [FilePath] -> io [FilePath]
-getGrammarPath lib_dirs = liftIO $ do
+getGrammarPath :: MonadIO io => FilePath -> io [FilePath]
+getGrammarPath lib_dir = liftIO $ do
   catch (fmap splitSearchPath $ getEnv gfGrammarPathVar) 
-        (\_ -> return $ concat [[lib_dir </> "alltenses", lib_dir </> "prelude"]
-                               | lib_dir <- lib_dirs ])     -- e.g. GF_GRAMMAR_PATH
+        (\_ -> return [lib_dir </> "alltenses",lib_dir </> "prelude"])     -- 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 = 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)
+  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
   mapM canonicalizePath ps
   where
     allSubdirs :: FilePath -> IO [FilePath]
@@ -85,15 +80,11 @@ extendPathEnv opts = liftIO $ do
     allSubdirs p = case last p of
       '*' -> do let path = init p
                 fs <- getSubdirs path
-                let starpaths = [path </> f | f <- fs]
-                when (verbAtLeast opts Verbose) $ putStrLn ("extendPathEnv: allSubdirs: * found "++show starpaths)
-                return starpaths
+                return [path </> f | f <- fs]
       _   -> do exists <- doesDirectoryExist p
                 if exists
-                  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)
+                  then return [p]
+                  else do when (verbAtLeast opts Verbose) $ putStrLn ("ignore path "++p)
                           return []
 
 getSubdirs :: FilePath -> IO [FilePath]

src/compiler/GF/Interactive.hs

@@ -5,7 +5,7 @@ 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(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands)
+import GF.Command.Commands(HasPGF(..),pgfCommands)
 import GF.Command.CommonCommands(commonCommands,extend)
 import GF.Command.SourceCommands
 import GF.Command.CommandInfo
@@ -20,15 +20,12 @@ import GF.Infra.SIO
 import GF.Infra.Option
 import qualified System.Console.Haskeline as Haskeline
 
-import PGF
-import PGF.Internal(abstract,funs,lookStartCat,emptyPGF)
+import PGF2
 
 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)
@@ -38,9 +35,6 @@ import GF.Server(server)
 #endif
 
 import GF.Command.Messages(welcome)
-import GF.Infra.UseIO (Output)
--- Provides an orphan instance of MonadFail for StateT in ghc versions < 8
-import Control.Monad.Trans.Instances ()
 
 -- | Run the GF Shell in quiet mode (@gf -run@).
 mainRunGFI :: Options -> [FilePath] -> IO ()
@@ -56,6 +50,7 @@ mainGFI opts files = do
 
 shell opts files = flip evalStateT (emptyGFEnv opts) $
                    do mapStateT runSIO $ importInEnv opts files
+                      modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
                       loop
 
 #ifdef SERVER_MODE
@@ -280,17 +275,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,pgfEnv pgf)}
+              modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgf)}
       else do pgf1 <- lift $ importPGF pgf0
               modify $ \ gfenv->gfenv { retain=False,
-                                        pgfenv = (emptyGrammar,pgfEnv pgf1) }
+                                        pgfenv = (emptyGrammar,pgf1) }
   where
     importPGF pgf0 =
       do let opts' = addOptions (setOptimization OptCSE False) opts
          pgf1 <- importGrammar pgf0 opts' files
          if (verbAtLeast opts Normal)
-           then putStrLnFlush $
-                  unwords $ "\nLanguages:" : map showCId (languages pgf1)
+           then case pgf1 of
+                  Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
+                  Nothing  -> return ()
            else return ()
          return pgf1
 
@@ -301,12 +297,12 @@ tryGetLine = do
    Right l -> return l
 
 prompt env
-  | retain env || abs == wildCId = "> "
-  | otherwise      = showCId abs ++ "> "
-  where
-    abs = abstractName (multigrammar env)
+  | retain env = "> "
+  | otherwise  = case multigrammar env of
+                   Just pgf -> abstractName pgf ++ "> "
+                   Nothing  -> "> "
 
-type CmdEnv = (Grammar,PGFEnv)
+type CmdEnv = (Grammar,Maybe PGF)
 
 data GFEnv = GFEnv {
     startOpts :: Options,
@@ -318,10 +314,10 @@ data GFEnv = GFEnv {
 
 emptyGFEnv opts = GFEnv opts False emptyCmdEnv emptyCommandEnv []
 
-emptyCmdEnv = (emptyGrammar,pgfEnv emptyPGF)
+emptyCmdEnv = (emptyGrammar,Nothing)
 
 emptyCommandEnv = mkCommandEnv allCommands
-multigrammar = pgf . snd . pgfenv
+multigrammar = snd . pgfenv
 
 allCommands =
   extend pgfCommands (helpCommand allCommands:moreCommands)
@@ -329,24 +325,35 @@ allCommands =
   `Map.union` commonCommands
 
 instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv)
-instance HasPGFEnv ShellM where getPGFEnv = gets (snd . pgfenv)
+instance HasPGF ShellM where getPGF = 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
-      -> 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 []
+      -> 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 | ParseOk res <- [complete lang cat s prefix], (t,_,_,_) <- res]
+                                                    in ret (length prefix) (map Haskeline.simpleCompletion compls)
+                            _                    -> ret 0 []
+           Nothing  -> 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]
@@ -357,23 +364,15 @@ wordCompletion gfenv (left,right) = do
     CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
       -> Haskeline.completeFilename (left,right)
     CmplIdent _ 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) []
+      -> case multigrammar gfenv of
+           Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
+           Nothing  -> 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 nextState ps (simpleParseInput t) of
+    loop ps (t:ts) = case error "nextState ps (simpleParseInput t)" of
                        Left  es -> Nothing
                        Right ps -> loop ps ts
 
@@ -433,7 +432,7 @@ wc_type = cmd_name
         x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
 
         cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
-	        [x] -> Just x
+                [x] -> Just x
                 _   -> Nothing
 
     isIdent c = c == '_' || c == '\'' || isAlphaNum c

src/compiler/GF/Interactive2.hs

@@ -1,442 +0,0 @@
-{-# 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,10 +2,7 @@
 {-# LANGUAGE CPP #-}
 module GF.Main where
 import GF.Compiler
-import qualified GF.Interactive as GFI1
-#ifdef C_RUNTIME
-import qualified GF.Interactive2 as GFI2
-#endif
+import GF.Interactive
 import GF.Data.ErrM
 import GF.Infra.Option
 import GF.Infra.UseIO
@@ -16,18 +13,19 @@ import Data.Version
 import System.Directory
 import System.Environment (getArgs)
 import System.Exit
-import GF.System.Console (setConsoleEncoding)
+-- import GF.System.Console (setConsoleEncoding)
 
 -- | Run the GF main program, taking arguments from the command line.
 -- (It calls 'setConsoleEncoding' and 'getOptions', then 'mainOpts'.)
 -- Run @gf --help@ for usage info.
 main :: IO ()
 main = do
-  --setConsoleEncoding
+  -- setConsoleEncoding
   uncurry mainOpts =<< getOptions
 
 -- | Get and parse GF command line arguments. Fix relative paths.
 -- Calls 'getArgs' and 'parseOptions'.
+getOptions :: IO (Options, [FilePath])
 getOptions = do
   args <- getArgs
   case parseOptions args of
@@ -43,21 +41,11 @@ getOptions = do
 -- the options it invokes 'mainGFC', 'mainGFI', 'mainRunGFI', 'mainServerGFI',
 -- or it just prints version/usage info.
 mainOpts :: Options -> [FilePath] -> IO ()
-mainOpts opts files = 
+mainOpts opts files =
     case flag optMode opts of
       ModeVersion     -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
       ModeHelp        -> putStrLn helpMessage
-      ModeServer port -> GFI1.mainServerGFI opts port files
+      ModeServer port -> mainServerGFI opts port files
       ModeCompiler    -> mainGFC 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
+      ModeInteractive -> mainGFI opts files
+      ModeRun         -> mainRunGFI opts files

src/compiler/GF/Quiz.hs

@@ -18,13 +18,8 @@ module GF.Quiz (
   morphologyList
   ) where
 
-import PGF
---import PGF.Linearize
+import PGF2
 import GF.Data.Operations
---import GF.Infra.UseIO
---import GF.Infra.Option
---import PGF.Probabilistic
-
 import System.Random
 import Data.List (nub)
 
@@ -38,7 +33,7 @@ mkQuiz msg tts = do
   teachDialogue qas msg
 
 translationList :: 
-  Maybe Expr -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])]
+  Maybe Expr -> PGF -> Concr -> Concr -> Type -> Int -> IO [(String,[String])]
 translationList mex pgf ig og typ number = do
   gen <- newStdGen
   let ts   = take number $ case mex of
@@ -46,19 +41,22 @@ translationList mex pgf ig og typ number = do
                              Nothing -> generateRandom     gen pgf typ
   return $ map mkOne $ ts
  where
-   mkOne t = (norml (linearize pgf ig t), 
+   mkOne t = (norml (linearize ig t), 
               map norml (concatMap lins (homonyms t)))
-   homonyms = parse pgf ig typ . linearize pgf ig
-   lins = nub . concatMap (map snd) . tabularLinearizes pgf og
+   homonyms t = 
+     case (parse ig typ . linearize ig) t of
+       ParseOk res -> map fst res
+       _           -> []
+   lins = nub . concatMap (map snd) . tabularLinearizeAll og
 
 morphologyList :: 
-  Maybe Expr -> PGF -> Language -> Type -> Int -> IO [(String,[String])]
+  Maybe Expr -> PGF -> Concr -> 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 (tabularLinearizes pgf ig) ts
+  let ss    = map (tabularLinearizeAll 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,7 +3,6 @@
 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.Except(ExceptT(..),runExceptT)
@@ -34,7 +33,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(JSValue(..),Result(..),valFromObj,encode,decode,showJSON,makeObj)
+import Text.JSON(encode,showJSON,makeObj)
 --import System.IO.Silently(hCapture)
 import System.Process(readProcessWithExitCode)
 import System.Exit(ExitCode(..))
@@ -43,7 +42,6 @@ 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)
@@ -171,7 +169,6 @@ 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
@@ -180,7 +177,7 @@ handle logLn documentroot state0 cache execute1 stateVar
 
     translatePath rpath = root</>rpath -- hmm, check for ".."
 
-    versionInfo (c1,c2) =
+    versionInfo c =
         html200 . unlines $
            "<!DOCTYPE html>":
            "<meta name = \"viewport\" content = \"width = device-width\">":
@@ -188,8 +185,7 @@ handle logLn documentroot state0 cache execute1 stateVar
            "":
            ("<h2>"++hdr++"</h2>"):
            (zipWith (++) ("<p>":repeat "<br>") buildinfo)++
-           sh "Haskell run-time system" c1++
-           sh "C run-time system" c2
+           sh "Run-time system" c
       where
         hdr:buildinfo = lines gf_version
         rel = makeRelative documentroot
@@ -284,17 +280,13 @@ handle logLn documentroot state0 cache execute1 stateVar
     skip_empty = filter (not.null.snd)
 
     jsonList = jsonList' return
-    jsonListLong ext = jsonList' (mapM (addTime ext)) ext
+    jsonListLong = jsonList' (mapM addTime)
     jsonList' details ext = fmap (json200) (details =<< ls_ext "." ext)
 
-    addTime ext path =
+    addTime path =
         do t <- getModificationTime path
-           if ext==".json"
-             then addComment (time t) <$> liftIO (try $ getComment path)
-             else return . makeObj $ time t
+           return $ makeObj ["path".=path,"time".=format 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 =
@@ -336,11 +328,6 @@ 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,7 +14,6 @@ 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/FiniteState.hs

@@ -5,37 +5,37 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/10 16:43:44 $ 
+-- > CVS $Date: 2005/11/10 16:43:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.16 $
 --
 -- A simple finite state network module.
 -----------------------------------------------------------------------------
 module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
-			      startState, finalStates,
-			      states, transitions,
+                              startState, finalStates,
+                              states, transitions,
                               isInternal,
-			      newFA, newFA_,
-			      addFinalState,
-			      newState, newStates,
+                              newFA, newFA_,
+                              addFinalState,
+                              newState, newStates,
                               newTransition, newTransitions,
                               insertTransitionWith, insertTransitionsWith,
-			      mapStates, mapTransitions,
+                              mapStates, mapTransitions,
                               modifyTransitions,
-                              nonLoopTransitionsTo, nonLoopTransitionsFrom, 
+                              nonLoopTransitionsTo, nonLoopTransitionsFrom,
                               loops,
                               removeState,
                               oneFinalState,
                               insertNFA,
                               onGraph,
-			      moveLabelsToNodes, removeTrivialEmptyNodes,
+                              moveLabelsToNodes, removeTrivialEmptyNodes,
                               minimize,
                               dfa2nfa,
                               unusedNames, renameStates,
-			      prFAGraphviz, faToGraphviz) where
+                              prFAGraphviz, faToGraphviz) where
 
 import Data.List
-import Data.Maybe 
+import Data.Maybe
 --import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l))
 newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
 newTransitions es = onGraph (newEdges es)
 
-insertTransitionWith :: Eq n => 
+insertTransitionWith :: Eq n =>
                         (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
 insertTransitionWith f t = onGraph (insertEdgeWith f t)
 
-insertTransitionsWith :: Eq n => 
+insertTransitionsWith :: Eq n =>
                          (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
-insertTransitionsWith f ts fa = 
+insertTransitionsWith f ts fa =
     foldl' (flip (insertTransitionWith f)) fa ts
 
 mapStates :: (a -> c) -> FA n a b -> FA n c b
@@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names
 -- | Gets all incoming transitions to a given state, excluding
 -- transtions from the state itself.
 nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsTo s fa = 
+nonLoopTransitionsTo s fa =
     [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s]
 
 nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsFrom s fa = 
+nonLoopTransitionsFrom s fa =
     [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s]
 
 loops :: Eq n => n -> FA n a b -> [b]
@@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names
 renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
     where (ns,rest) = splitAt (length (nodes g)) supply
           newNodes = Map.fromList (zip (map fst (nodes g)) ns)
-	  newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
+          newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
           s' = newName s
           fs' = map newName fs
 
@@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into
           -> (State, State) -- ^ States to insert between
           -> NFA a -- ^ NFA to insert.
           -> NFA a
-insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) 
+insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
     = FA (newEdges es g') s1 fs1
-    where 
+    where
     es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
     (g',ren) = mergeGraphs g1 g2
 
@@ -182,9 +182,9 @@ oneFinalState nl el fa =
 moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
 moveLabelsToNodes = onGraph f
   where f g@(Graph c _ _) = Graph c' ns (concat ess)
-	    where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
-		  (c',is') = mapAccumL fixIncoming c is
-		  (ns,ess) = unzip (concat is')
+         where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
+               (c',is') = mapAccumL fixIncoming c is
+               (ns,ess) = unzip (concat is')
 
 
 -- | Remove empty nodes which are not start or final, and have
@@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
 --   This is not done if the pointed-to node is a final node.
 skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
 skipSimpleEmptyNodes fa = onGraph og fa
-  where 
+  where
   og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es')
     where
     es' = concatMap changeEdge es
     info = nodeInfo g
-    changeEdge e@(f,t,()) 
+    changeEdge e@(f,t,())
       | isNothing (getNodeLabel info t)
        -- && (i * o <= i + o)
         && not (isFinal fa t)
@@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa
  where
  f g = if Set.null rns then g else f (removeNodes rns g)
   where info = nodeInfo g
-        rns = Set.fromList [ n | (n,_) <- nodes g, 
+        rns = Set.fromList [ n | (n,_) <- nodes g,
                              isInternal fa n,
-                             inDegree info n == 0 
+                             inDegree info n == 0
                              || outDegree info n == 0]
 
-fixIncoming :: (Ord n, Eq a) => [n] 
+fixIncoming :: (Ord n, Eq a) => [n]
             -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
             -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
                                                       -- incoming edges.
 fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
   where ls = nub $ map edgeLabel es
-	(cs',cs'') = splitAt (length ls) cs
-	newNodes = zip cs' ls
-	es' = [ (x,n,()) | x <- map fst newNodes ]
-	-- separate cyclic and non-cyclic edges
-	(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-	          -- keep all incoming non-cyclic edges with the right label
-	to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-	          -- for each cyclic edge with the right label, 
-	          -- add an edge from each of the new nodes (including this one)
-		    ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
-	newContexts = [ (v, to v) | v <- newNodes ]
+        (cs',cs'') = splitAt (length ls) cs
+        newNodes = zip cs' ls
+        es' = [ (x,n,()) | x <- map fst newNodes ]
+        -- separate cyclic and non-cyclic edges
+        (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
+                  -- keep all incoming non-cyclic edges with the right label
+        to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
+                  -- for each cyclic edge with the right label,
+                  -- add an edge from each of the new nodes (including this one)
+                  ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
+        newContexts = [ (v, to v) | v <- newNodes ]
 
 --alphabet :: Eq b => Graph n a (Maybe b) -> [b]
 --alphabet = nub . catMaybes . map edgeLabel . edges
@@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
                              (ns',es') = (Set.toList ns, Set.toList es)
                              final = filter isDFAFinal ns'
                              fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
- 		          in renameStates [0..] fa
+                         in renameStates [0..] fa
   where info = nodeInfo g
 --        reach = nodesReachable out
-	start = closure info $ Set.singleton s
+        start = closure info $ Set.singleton s
         isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
-	h currentStates oldStates es
-	    | Set.null currentStates = (oldStates,es)
-	    | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
-	    where 
-	    allOldStates = oldStates `Set.union` currentStates
+        h currentStates oldStates es
+            | Set.null currentStates = (oldStates,es)
+            | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
+            where
+            allOldStates = oldStates `Set.union` currentStates
             (newStates,es') = new (Set.toList currentStates) Set.empty es
-	    uniqueNewStates = newStates Set.\\ allOldStates
-        -- Get the sets of states reachable from the given states 
+            uniqueNewStates = newStates Set.\\ allOldStates
+        -- Get the sets of states reachable from the given states
         -- by consuming one symbol, and the associated edges.
         new [] rs es = (rs,es)
         new (n:ns) rs es = new ns rs' es'
@@ -281,7 +281,7 @@ closure info x = closure_ x x
   where closure_ acc check | Set.null check = acc
                            | otherwise = closure_ acc' check'
             where
-            reach = Set.fromList [y | x <- Set.toList check, 
+            reach = Set.fromList [y | x <- Set.toList check,
                                       (_,y,Nothing) <- getOutgoing info x]
             acc' = acc `Set.union` reach
             check' = reach Set.\\ acc
@@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,
 reverseNFA :: NFA a -> NFA a
 reverseNFA (FA g s fs) = FA g''' s' [s]
     where g' = reverseGraph g
-	  (g'',s') = newNode () g'
-	  g''' = newEdges [(s',f,Nothing) | f <- fs] g''
+          (g'',s') = newNode () g'
+          g''' = newEdges [(s',f,Nothing) | f <- fs] g''
 
 dfa2nfa :: DFA a -> NFA a
 dfa2nfa = mapTransitions Just
@@ -313,13 +313,13 @@ prFAGraphviz  = Dot.prGraphviz . faToGraphviz
 --prFAGraphviz_  = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show
 
 faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
-faToGraphviz (FA (Graph _ ns es) s f) 
+faToGraphviz (FA (Graph _ ns es) s f)
     = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
    where mkNode (n,l) = Dot.Node (show n) attrs
-	     where attrs = [("label",l)]
-			   ++ if n == s then [("shape","box")] else []
-			   ++ if n `elem` f then [("style","bold")] else []
-	 mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
+          where attrs = [("label",l)]
+                 ++ if n == s then [("shape","box")] else []
+                 ++ if n `elem` f then [("style","bold")] else []
+         mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
 
 --
 -- * Utilities

src/compiler/GF/Speech/GSL.hs

@@ -7,15 +7,13 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.GSL (gslPrinter) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
---import GF.Data.Utilities
+import Prelude hiding ((<>))
 import GF.Grammar.CFG
 import GF.Speech.SRG
 import GF.Speech.RegExp
 import GF.Infra.Option
---import GF.Infra.Ident
-import PGF
+import PGF2
 
 import Data.Char (toUpper,toLower)
 import Data.List (partition)
@@ -24,16 +22,16 @@ import GF.Text.Pretty
 width :: Int
 width = 75
 
-gslPrinter :: Options -> PGF -> CId -> String
+gslPrinter :: Options -> PGF -> Concr -> String
 gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
-  where st = style { lineLength = width } 
+  where st = style { lineLength = width }
 
 prGSL :: SRG -> Doc
 prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
     where
     header = ";GSL2.0" $$
-	     comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
-             comment ("Generated by GF") 
+             comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
+             comment ("Generated by GF")
     mainCat = ".MAIN" <+> prCat (srgStartCat srg)
     prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs)
     -- FIXME: use the probability

src/compiler/GF/Speech/JSGF.hs

@@ -11,15 +11,14 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.JSGF (jsgfPrinter) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
---import GF.Data.Utilities
+import Prelude hiding ((<>))
 import GF.Infra.Option
 import GF.Grammar.CFG
 import GF.Speech.RegExp
 import GF.Speech.SISR
 import GF.Speech.SRG
-import PGF
+import PGF2
 
 import Data.Char
 import Data.List
@@ -31,8 +30,8 @@ width :: Int
 width = 75
 
 jsgfPrinter :: Options
-	    -> PGF 
-            -> CId -> String
+	        -> PGF 
+            -> Concr -> String
 jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
   where st = style { lineLength = width }
         sisr = flag optSISR opts
@@ -44,7 +43,7 @@ prJSGF sisr srg
     header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$
              comment ("JSGF speech recognition grammar for " ++ srgName srg) $$
              comment "Generated by GF" $$
-	     ("grammar " ++ srgName srg ++ ";") 
+             ("grammar " ++ srgName srg ++ ";")
     lang = maybe empty pp (srgLanguage srg)
     mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
     prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs)
@@ -62,7 +61,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
 prItem sisr t = f 0
   where
     f _ (REUnion [])  = pp "<VOID>"
-    f p (REUnion xs) 
+    f p (REUnion xs)
         | not (null es) = brackets (f 0 (REUnion nes))
         | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
       where (es,nes) = partition isEpsilon xs
@@ -110,4 +109,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
 
 ($++$) :: Doc -> Doc -> Doc
 x $++$ y = x $$ emptyLine $$ y
-

src/compiler/GF/Speech/PGFToCFG.hs

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

src/compiler/GF/Speech/PrRegExp.hs

@@ -11,12 +11,12 @@ import GF.Grammar.CFG
 import GF.Speech.CFGToFA
 import GF.Speech.PGFToCFG
 import GF.Speech.RegExp
-import PGF
+import PGF2
 
-regexpPrinter :: PGF -> CId -> String
+regexpPrinter :: PGF -> Concr -> String
 regexpPrinter pgf cnc = (++"\n") $ prRE id $ dfa2re $ cfgToFA $ pgfToCFG pgf cnc
 
-multiRegexpPrinter :: PGF -> CId -> String
+multiRegexpPrinter :: PGF -> Concr -> String
 multiRegexpPrinter pgf cnc = prREs $ mfa2res $ cfgToMFA $ pgfToCFG pgf cnc
 
 prREs :: [(String,RE CFSymbol)] -> String

src/compiler/GF/Speech/SISR.hs

@@ -10,13 +10,9 @@ module GF.Speech.SISR (SISRFormat(..), SISRTag, prSISR,
 
 import Data.List
 
---import GF.Data.Utilities
---import GF.Infra.Ident
 import GF.Infra.Option (SISRFormat(..))
 import GF.Grammar.CFG
 import GF.Speech.SRG (SRGNT)
-import PGF(showCId)
-
 import qualified GF.JavaScript.AbsJS   as JS
 import qualified GF.JavaScript.PrintJS as JS
 
@@ -50,12 +46,12 @@ catSISR t (c,i) fmt
 profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag
 profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term]
   where 
-        f (CFObj n ts) = tree (showCId n) (map f ts)
+        f (CFObj n ts) = tree n (map f ts)
         f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)]
         f (CFApp x y) = JS.ECall (f x) [f y]
         f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i))
         f (CFVar v) = JS.EVar (var v)
-        f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr (showCId typ))]
+        f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr typ)]
 
 fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$")
 fmtOut SISR_1_0 = JS.EVar (JS.Ident "out")

src/compiler/GF/Speech/SLF.hs

@@ -16,17 +16,14 @@ module GF.Speech.SLF (slfPrinter,slfGraphvizPrinter,
 import GF.Data.Utilities
 import GF.Grammar.CFG
 import GF.Speech.FiniteState
---import GF.Speech.CFG
 import GF.Speech.CFGToFA
 import GF.Speech.PGFToCFG
 import qualified GF.Data.Graphviz as Dot
-import PGF
---import PGF.CId
+import PGF2
 
 import Control.Monad
 import qualified Control.Monad.State as STM
 import Data.Char (toUpper)
---import Data.List
 import Data.Maybe
 
 data SLFs = SLFs [(String,SLF)] SLF
@@ -43,7 +40,7 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
 
 type SLF_FA = FA State (Maybe CFSymbol) ()
 
-mkFAs :: PGF -> CId -> (SLF_FA, [(String,SLF_FA)])
+mkFAs :: PGF -> Concr -> (SLF_FA, [(String,SLF_FA)])
 mkFAs pgf cnc = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
   where MFA start subs = {- renameSubs $ -} cfgToMFA $ pgfToCFG pgf cnc
         main = let (fa,s,f) = newFA_ in newTransition s f (NonTerminal start) fa
@@ -64,7 +61,7 @@ renameSubs (MFA start subs) = MFA (newName start) subs'
 -- * SLF graphviz printing (without sub-networks)
 --
 
-slfGraphvizPrinter :: PGF -> CId -> String
+slfGraphvizPrinter :: PGF -> Concr -> String
 slfGraphvizPrinter pgf cnc
     = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
   where 
@@ -74,7 +71,7 @@ slfGraphvizPrinter pgf cnc
 -- * SLF graphviz printing (with sub-networks)
 --
 
-slfSubGraphvizPrinter :: PGF -> CId -> String
+slfSubGraphvizPrinter :: PGF -> Concr -> String
 slfSubGraphvizPrinter pgf cnc = Dot.prGraphviz g
   where (main, subs) = mkFAs pgf cnc
         g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] 
@@ -100,7 +97,7 @@ gvSLFFA n fa =
 -- * SLF printing (without sub-networks)
 --
 
-slfPrinter :: PGF -> CId -> String
+slfPrinter :: PGF -> Concr -> String
 slfPrinter pgf cnc
     = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
 
@@ -109,7 +106,7 @@ slfPrinter pgf cnc
 --
 
 -- | Make a network with subnetworks in SLF
-slfSubPrinter :: PGF -> CId -> String
+slfSubPrinter :: PGF -> Concr -> String
 slfSubPrinter pgf cnc = prSLFs slfs
   where 
   (main,subs) = mkFAs pgf cnc

src/compiler/GF/Speech/SRG.hs

@@ -2,8 +2,8 @@
 -- |
 -- Module      : SRG
 --
--- Representation of, conversion to, and utilities for 
--- printing of a general Speech Recognition Grammar. 
+-- Representation of, conversion to, and utilities for
+-- printing of a general Speech Recognition Grammar.
 --
 -- FIXME: remove \/ warn \/ fail if there are int \/ string literal
 -- categories in the grammar
@@ -17,21 +17,15 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
                      , lookupFM_
                      ) where
 
---import GF.Data.Operations
+import PGF2
 import GF.Data.Utilities
---import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.CFG
 import GF.Speech.PGFToCFG
---import GF.Data.Relation
---import GF.Speech.FiniteState
 import GF.Speech.RegExp
 import GF.Speech.CFGToFA
---import GF.Infra.Option
-import PGF
 
 import Data.List
---import Data.Maybe (fromMaybe, maybeToList)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -40,20 +34,20 @@ import qualified Data.Set as Set
 --import Debug.Trace
 
 data SRG = SRG { srgName :: String    -- ^ grammar name
-		 , srgStartCat :: Cat     -- ^ start category name
-                 , srgExternalCats :: Set Cat
-                 , srgLanguage :: Maybe String -- ^ The language for which the grammar 
-                                                   --   is intended, e.g. en-UK
-	         , srgRules :: [SRGRule] 
-	       }
-	 deriving (Eq,Show)
+               , srgStartCat :: Cat     -- ^ start category name
+               , srgExternalCats :: Set Cat
+               , srgLanguage :: Maybe String -- ^ The language for which the grammar
+                                             --   is intended, e.g. en-UK
+               , srgRules :: [SRGRule]
+               }
+        deriving (Eq,Show)
 
 data SRGRule = SRGRule Cat [SRGAlt]
-	     deriving (Eq,Show)
+        deriving (Eq,Show)
 
 -- | maybe a probability, a rule name and an EBNF right-hand side
 data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem
-	      deriving (Eq,Show)
+        deriving (Eq,Show)
 
 type SRGItem = RE SRGSymbol
 
@@ -62,25 +56,25 @@ type SRGSymbol = Symbol SRGNT Token
 -- | An SRG non-terminal. Category name and its number in the profile.
 type SRGNT = (Cat, Int)
 
-ebnfPrinter :: Options -> PGF -> CId -> String
+ebnfPrinter :: Options -> PGF -> Concr -> String
 ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
 
 -- | Create a compact filtered non-left-recursive SRG. 
-makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
+makeNonLeftRecursiveSRG :: Options -> PGF -> Concr -> SRG
 makeNonLeftRecursiveSRG opts = makeSRG opts'
     where
       opts' = setDefaultCFGTransform opts CFGNoLR True
 
-makeSRG :: Options -> PGF -> CId -> SRG
+makeSRG :: Options -> PGF -> Concr -> SRG
 makeSRG opts = mkSRG cfgToSRG preprocess
     where
       cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
       preprocess =   maybeTransform opts CFGMergeIdentical mergeIdentical
-                   . maybeTransform opts CFGNoLR removeLeftRecursion 
+                   . maybeTransform opts CFGNoLR removeLeftRecursion
                    . maybeTransform opts CFGRegular makeRegular
                    . maybeTransform opts CFGTopDownFilter topDownFilter
                    . maybeTransform opts CFGBottomUpFilter bottomUpFilter
-                   . maybeTransform opts CFGRemoveCycles removeCycles 
+                   . maybeTransform opts CFGRemoveCycles removeCycles
                    . maybeTransform opts CFGStartCatOnly purgeExternalCats
 
 setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
@@ -95,9 +89,9 @@ stats g = "Categories: " ++ show (countCats g)
           ++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
           ++ ", Rules: " ++ show (countRules g)
 -}
-makeNonRecursiveSRG :: Options 
+makeNonRecursiveSRG :: Options
                     -> PGF
-                    -> CId -- ^ Concrete syntax name.
+                    -> Concr
                     -> SRG
 makeNonRecursiveSRG opts = mkSRG cfgToSRG id
     where
@@ -105,32 +99,32 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
           where
             MFA _ dfas = cfgToMFA cfg
             dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re
-            dummyCFTerm = CFMeta (mkCId "dummy")
+            dummyCFTerm = CFMeta "dummy"
             dummySRGNT = mapSymbol (\c -> (c,0)) id
 
-mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
+mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> Concr -> SRG
 mkSRG mkRules preprocess pgf cnc =
-    SRG { srgName = showCId cnc,
-	  srgStartCat = cfgStartCat cfg,
+    SRG { srgName = concreteName cnc,
+	      srgStartCat = cfgStartCat cfg,
           srgExternalCats = cfgExternalCats cfg,
-          srgLanguage = languageCode pgf cnc,
+          srgLanguage = languageCode cnc,
 	  srgRules = mkRules cfg }
-    where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
+    where cfg = renameCats (concreteName cnc) $ preprocess $ pgfToCFG pgf cnc
 
--- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), 
+-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
 --   to C_N where N is an integer.
 renameCats :: String -> CFG -> CFG
 renameCats prefix cfg = mapCFGCats renameCat cfg
   where renameCat c | isExternal c = c ++ "_cat"
                     | otherwise = Map.findWithDefault (badCat c) c names
-        isExternal c = c `Set.member` cfgExternalCats cfg        
+        isExternal c = c `Set.member` cfgExternalCats cfg
         catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)]
         names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]]
         badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg)
 
 cfRulesToSRGRule :: [CFRule] -> SRGRule
 cfRulesToSRGRule rs@(r:_) = SRGRule (ruleLhs r) rhs
-    where 
+    where
       alts = [((n,Nothing),mkSRGSymbols 0 ss) | Rule c ss n <- rs]
       rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ]
 
@@ -153,7 +147,7 @@ srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats)
 -- non-optimizing version:
 --srgItem = unionRE . map seqRE
 
--- | Merges a list of right-hand sides which all have the same 
+-- | Merges a list of right-hand sides which all have the same
 -- sequence of non-terminals.
 mergeItems :: [[SRGSymbol]] -> SRGItem
 mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens
@@ -174,16 +168,16 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map
 
 prSRG :: Options -> SRG -> String
 prSRG opts srg = prProductions $ map prRule $ ext ++ int
-    where 
+    where
       sisr = flag optSISR opts
       (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg)
       prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts)))
-      prAlt (SRGAlt _ t rhs) = 
-          -- FIXME: hack: we high-jack the --sisr flag to add 
+      prAlt (SRGAlt _ t rhs) =
+          -- FIXME: hack: we high-jack the --sisr flag to add
           -- a simple lambda calculus format for semantic interpretation
           -- Maybe the --sisr flag should be renamed.
           case sisr of
-            Just _  -> 
+            Just _  ->
                 -- copy tags to each part of a top-level union,
                 -- to get simpler output
                 case rhs of

src/compiler/GF/Speech/SRGS_ABNF.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/01 20:09:04 $ 
+-- > CVS $Date: 2005/11/01 20:09:04 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.16 $
 --
@@ -18,31 +18,27 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
---import GF.Data.Utilities
+import Prelude hiding ((<>))
 import GF.Infra.Option
 import GF.Grammar.CFG
 import GF.Speech.SISR as SISR
 import GF.Speech.SRG
 import GF.Speech.RegExp
-import PGF (PGF, CId)
+import PGF2 (PGF,Concr)
 
---import Data.Char
 import Data.List
 import Data.Maybe
 import GF.Text.Pretty
---import Debug.Trace
 
 width :: Int
 width = 75
 
-srgsAbnfPrinter :: Options
-	        -> PGF -> CId -> String
+srgsAbnfPrinter :: Options -> PGF -> Concr -> String
 srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
     where sisr = flag optSISR opts
 
-srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String
+srgsAbnfNonRecursivePrinter :: Options -> PGF -> Concr -> String
 srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 showDoc = renderStyle (style { lineLength = width })
@@ -72,7 +68,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
 prItem sisr t = f 0
   where
     f _ (REUnion [])  = pp "$VOID"
-    f p (REUnion xs) 
+    f p (REUnion xs)
         | not (null es) = brackets (f 0 (REUnion nes))
         | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
       where (es,nes) = partition isEpsilon xs
@@ -84,13 +80,13 @@ prItem sisr t = f 0
 
 prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
 prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
-prSymbol _ cn (Terminal t) 
+prSymbol _ cn (Terminal t)
     | all isPunct t = empty  -- removes punctuation
     | otherwise = pp t -- FIXME: quote if there is whitespace or odd chars
 
 tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
 tag Nothing _ = empty
-tag (Just fmt) t = 
+tag (Just fmt) t =
     case t fmt of
       [] -> empty
       -- grr, silly SRGS ABNF does not have an escaping mechanism
@@ -125,4 +121,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
 
 ($++$) :: Doc -> Doc -> Doc
 x $++$ y = x $$ emptyLine $$ y
-

src/compiler/GF/Speech/SRGS_XML.hs

@@ -13,7 +13,7 @@ import GF.Grammar.CFG
 import GF.Speech.RegExp
 import GF.Speech.SISR as SISR
 import GF.Speech.SRG
-import PGF (PGF, CId, Token)
+import PGF2 (PGF, Concr)
 
 --import Control.Monad
 --import Data.Char (toUpper,toLower)
@@ -22,11 +22,11 @@ import Data.Maybe
 --import qualified Data.Map as Map
 
 srgsXmlPrinter :: Options
-               -> PGF -> CId -> String
+               -> PGF -> Concr -> String
 srgsXmlPrinter opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc
     where sisr = flag optSISR opts
 
-srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String
+srgsXmlNonRecursivePrinter :: Options -> PGF -> Concr -> String
 srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 
@@ -34,13 +34,13 @@ prSrgsXml :: Maybe SISRFormat -> SRG -> String
 prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
     where
     xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
-              [meta "description" 
+              [meta "description"
                  ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
                meta "generator" "Grammatical Framework"]
-	    ++ map ruleToXML (srgRules srg)
+               ++ map ruleToXML (srgRules srg)
     ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
         where pub = if isExternalCat srg cat then [("scope","public")] else []
-    prRhs rhss = [oneOf (map (mkProd sisr) rhss)] 
+    prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
 
 mkProd :: Maybe SISRFormat -> SRGAlt -> XML
 mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
@@ -50,9 +50,9 @@ mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
 
 mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
 mkItem sisr cn = f
-  where 
+  where
     f (REUnion [])  = ETag "ruleref" [("special","VOID")]
-    f (REUnion xs) 
+    f (REUnion xs)
         | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
         | otherwise = oneOf (map f xs)
       where (es,nes) = partition isEpsilon xs
@@ -62,7 +62,7 @@ mkItem sisr cn = f
     f (RESymbol s)  = symItem sisr cn s
 
 symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
-symItem sisr cn (NonTerminal n@(c,_)) = 
+symItem sisr cn (NonTerminal n@(c,_)) =
     Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
 symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]
 
@@ -81,12 +81,12 @@ oneOf = Tag "one-of" []
 grammar :: Maybe SISRFormat
         -> String  -- ^ root
         -> Maybe String -- ^language
-	-> [XML] -> XML
-grammar sisr root ml = 
+        -> [XML] -> XML
+grammar sisr root ml =
     Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
-		     ("version","1.0"),
-		     ("mode","voice"),
-		     ("root",root)]
+                     ("version","1.0"),
+                     ("mode","voice"),
+                     ("root",root)]
                  ++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
                  ++ maybe [] (\l -> [("xml:lang", l)]) ml
 
@@ -94,7 +94,7 @@ meta :: String -> String -> XML
 meta n c = ETag "meta" [("name",n),("content",c)]
 
 optimizeSRGS :: XML -> XML
-optimizeSRGS = bottomUpXML f 
+optimizeSRGS = bottomUpXML f
   where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
         f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
         f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs

src/compiler/GF/Speech/VoiceXML.hs

@@ -6,15 +6,8 @@
 -----------------------------------------------------------------------------
 module GF.Speech.VoiceXML (grammar2vxml) where
 
---import GF.Data.Operations
---import GF.Data.Str (sstrV)
---import GF.Data.Utilities
 import GF.Data.XML
---import GF.Infra.Ident
-import PGF
-import PGF.Internal
-
---import Control.Monad (liftM)
+import PGF2
 import Data.List (intersperse) -- isPrefixOf, find
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
@@ -22,59 +15,45 @@ import Data.Maybe (fromMaybe)
 --import Debug.Trace
 
 -- | the main function
-grammar2vxml :: PGF -> CId -> String
-grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
+grammar2vxml :: PGF -> Concr -> String
+grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name mb_language start skel qs) ""
     where skel = pgfSkeleton pgf
-          name = showCId cnc
-          qs = catQuestions pgf cnc (map fst skel)
-          language = languageCode pgf cnc
-          start = lookStartCat pgf
+          name = concreteName cnc
+          qs = catQuestions cnc (map fst skel)
+          mb_language = languageCode cnc
+          (_,start,_) = unType (startCat pgf)
 
 --
 -- * VSkeleton: a simple description of the abstract syntax.
 --
 
-type Skeleton = [(CId, [(CId, [CId])])]
+type Skeleton = [(Cat, [(Fun, [Cat])])]
 
 pgfSkeleton :: PGF -> Skeleton
-pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType (abstract pgf) f))) | (_,f) <- fs]) 
-                   | (c,(_,fs,_)) <- Map.toList (cats (abstract pgf))]
+pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]) | f <- functionsByCat pgf c, Just (hypos,_,_) <- [fmap unType (functionType pgf f)]])
+                     | c <- categories pgf]
 
 --
 -- * Questions to ask 
 --
 
-type CatQuestions = [(CId,String)]
+type CatQuestions = [(Cat,String)]
 
-catQuestions :: PGF -> CId -> [CId] -> CatQuestions
-catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats]
+catQuestions :: Concr -> [Cat] -> CatQuestions
+catQuestions cnc cats = [(c,catQuestion cnc c) | c <- cats]
 
-catQuestion :: PGF -> CId -> CId -> String
-catQuestion pgf cnc cat = showPrintName pgf cnc cat
+catQuestion :: Concr -> Cat -> String
+catQuestion cnc cat = fromMaybe cat (printName cnc cat)
 
-
-{-
-lin :: StateGrammar -> String -> Err String
-lin gr fun = do
-             tree <- string2treeErr gr fun
-             let ls = map unt $ linTree2strings noMark g c tree
-             case ls of
-                 [] -> fail $ "No linearization of " ++ fun
-                 l:_ -> return l
-  where c = cncId gr
-        g = stateGrammarST gr
-        unt = formatAsText 
--}
-
-getCatQuestion :: CId -> CatQuestions -> String
+getCatQuestion :: Cat -> CatQuestions -> String
 getCatQuestion c qs = 
-    fromMaybe (error "No question for category " ++ showCId c) (lookup c qs)
+    fromMaybe (error "No question for category " ++ c) (lookup c qs)
 
 --
 -- * Generate VoiceXML
 --
 
-skel2vxml :: String -> Maybe String -> CId -> Skeleton -> CatQuestions -> XML
+skel2vxml :: String -> Maybe String -> Cat -> Skeleton -> CatQuestions -> XML
 skel2vxml name language start skel qs = 
     vxml language ([startForm] ++ concatMap (uncurry (catForms gr qs)) skel)
   where 
@@ -86,12 +65,12 @@ grammarURI :: String -> String
 grammarURI name = name ++ ".grxml"
 
 
-catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
+catForms :: String -> CatQuestions -> Cat -> [(Fun, [Cat])] -> [XML]
 catForms gr qs cat fs = 
-    comments [showCId cat ++ " category."]
+    comments [cat ++ " category."]
     ++ [cat2form gr qs cat fs] 
 
-cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
+cat2form :: String -> CatQuestions -> Cat -> [(Fun, [Cat])] -> XML
 cat2form gr qs cat fs = 
   form (catFormId cat) $ 
       [var "old" Nothing, 
@@ -104,22 +83,22 @@ cat2form gr qs cat fs =
      ++ concatMap (uncurry (fun2sub gr cat)) fs
      ++ [block [return_ ["term"]{-]-}]]
 
-fun2sub :: String -> CId -> CId -> [CId] -> [XML]
+fun2sub :: String -> Cat -> Fun -> [Cat] -> [XML]
 fun2sub gr cat fun args = 
-    comments [showCId fun ++ " : (" 
-              ++ concat (intersperse ", " (map showCId args))
-              ++ ") " ++ showCId cat] ++ ss
+    comments [fun ++ " : (" 
+              ++ concat (intersperse ", " args)
+              ++ ") " ++ cat] ++ ss
   where 
   ss = zipWith mkSub [0..] args
   mkSub n t = subdialog s [("src","#"++catFormId t),
-                           ("cond","term.name == "++string (showCId fun))] 
+                           ("cond","term.name == "++string  fun)] 
               [param "old" v,
                filled [] [assign v (s++".term")]]
-    where s = showCId fun ++ "_" ++ show n
+    where s = fun ++ "_" ++ show n
           v = "term.args["++show n++"]"
 
-catFormId :: CId -> String
-catFormId c = showCId c ++ "_cat"
+catFormId :: Cat -> String
+catFormId c = c ++ "_cat"
 
 
 --

src/compiler/GF/System/NoSignal.hs

@@ -14,11 +14,11 @@
 
 module GF.System.NoSignal where
 
-import Control.Exception (Exception,catch)
+import Control.Exception (SomeException,catch)
 import Prelude hiding (catch)
 
 {-# NOINLINE runInterruptibly #-}
-runInterruptibly :: IO a -> IO (Either Exception a)
+runInterruptibly :: IO a -> IO (Either SomeException a)
 --runInterruptibly = fmap Right
 runInterruptibly a = 
     p `catch` h

src/compiler/GF/Text/Lexing.hs

@@ -15,7 +15,6 @@ stringOp good name = case name of
   "lexgreek"   -> Just $ appLexer lexAGreek
   "lexgreek2"  -> Just $ appLexer lexAGreek2
   "words"      -> Just $ appLexer words
-  "bind"       -> Just $ appUnlexer (unwords . bindTok)
   "unchars"    -> Just $ appUnlexer concat
   "unlextext"  -> Just $ appUnlexer (unlexText . unquote . bindTok)
   "unlexcode"  -> Just $ appUnlexer unlexCode