Merge pull request #196 from GrammaticalFramework/fix-code-generation

`import Control.Monad` when generating .hs with GADTs

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

@@ -12,28 +12,34 @@ jobs:
     name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
     runs-on: ${{ matrix.os }}
     strategy:
+      fail-fast: false
       matrix:
         os: [ubuntu-latest, macos-latest, windows-latest]
         cabal: ["latest"]
         ghc:
           - "8.6.5"
           - "8.8.3"
-          - "8.10.1"
+          - "8.10.7"
+          - "9.6.7"
         exclude:
           - os: macos-latest
             ghc: 8.8.3
           - os: macos-latest
             ghc: 8.6.5
+          - os: macos-latest
+            ghc: 8.10.7
           - os: windows-latest
             ghc: 8.8.3
           - os: windows-latest
             ghc: 8.6.5
+          - os: windows-latest
+            ghc: 8.10.7
 
     steps:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: haskell/actions/setup@v1
+    - uses: haskell-actions/setup@v2
       id: setup-haskell-cabal
       name: Setup Haskell
       with:
@@ -44,7 +50,7 @@ jobs:
       run: |
         cabal freeze
 
-    - uses: actions/cache@v1
+    - uses: actions/cache@v4
       name: Cache ~/.cabal/store
       with:
         path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
@@ -62,34 +68,40 @@ jobs:
 
   stack:
     name: stack / ghc ${{ matrix.ghc }}
-    runs-on: ubuntu-latest
+    runs-on: ${{ matrix.ghc == '7.10.3' && 'ubuntu-20.04' || 'ubuntu-latest' }}
     strategy:
+      fail-fast: false
       matrix:
         stack: ["latest"]
-        ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4"]
+        ghc: ["8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2", "9.6.7"]
-        # ghc: ["8.8.3"]
 
     steps:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: haskell/actions/setup@v1
+    - uses: haskell-actions/setup@v2
       name: Setup Haskell Stack
       with:
         ghc-version: ${{ matrix.ghc }}
         stack-version: 'latest'
         enable-stack: true
 
-    - uses: actions/cache@v1
+
+    # Fix linker errrors on ghc-7.10.3 for ubuntu (see https://github.com/commercialhaskell/stack/blob/255cd830627870cdef34b5e54d670ef07882523e/doc/faq.md#i-get-strange-ld-errors-about-recompiling-with--fpic)
+    - run: sed -i.bak 's/"C compiler link flags", "/&-no-pie /' /home/runner/.ghcup/ghc/7.10.3/lib/ghc-7.10.3/settings
+      if: matrix.ghc == '7.10.3'
+
+    - uses: actions/cache@v4
       name: Cache ~/.stack
       with:
         path: ~/.stack
-        key: ${{ runner.os }}-${{ matrix.ghc }}-stack
+        key: ${{ runner.os }}-${{ matrix.ghc }}-stack--${{ hashFiles(format('stack-ghc{0}', matrix.ghc)) }}
+        restore-keys: |
+             ${{ runner.os }}-${{ matrix.ghc }}-stack
 
     - name: Build
       run: |
-        stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
+        stack build --test --no-run-tests --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
-        # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
 
     - name: Test
       run: |

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

@@ -13,9 +13,9 @@ jobs:
     name: Build Ubuntu package
     strategy:
       matrix:
-        os:
+        ghc: ["9.6"]
-        - ubuntu-18.04
+        cabal: ["3.10"]
-        - ubuntu-20.04
+        os: ["ubuntu-24.04"]
 
     runs-on: ${{ matrix.os }}
 
@@ -25,12 +25,13 @@ jobs:
     # Note: `haskell-platform` is listed as requirement in debian/control,
     # which is why it's installed using apt instead of the Setup Haskell action.
 
-    # - name: Setup Haskell
+    - name: Setup Haskell
-    #   uses: actions/setup-haskell@v1
+      uses: haskell-actions/setup@v2
-    #   id: setup-haskell-cabal
+      id: setup-haskell-cabal
-    #   with:
+      with:
-    #     ghc-version: ${{ matrix.ghc }}
+        ghc-version: ${{ matrix.ghc }}
-    #     cabal-version: ${{ matrix.cabal }}
+        cabal-version: ${{ matrix.cabal }}
+      if: matrix.os == 'ubuntu-24.04'
 
     - name: Install build tools
       run: |
@@ -39,14 +40,15 @@ jobs:
           make \
           dpkg-dev \
           debhelper \
-          haskell-platform \
           libghc-json-dev \
-          python-dev \
           default-jdk \
+          python-dev-is-python3 \
           libtool-bin 
+        cabal install alex happy
         
     - name: Build package
       run: |
+        export PYTHONPATH="/home/runner/work/gf-core/gf-core/debian/gf/usr/local/lib/python3.12/dist-packages/"
         make deb
 
     - name: Copy package
@@ -54,7 +56,7 @@ jobs:
         cp ../gf_*.deb dist/
 
     - name: Upload artifact
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
         name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
         path: dist/gf_*.deb
@@ -64,14 +66,14 @@ jobs:
       run: |
         mv dist/gf_*.deb dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
 
-    - uses: actions/upload-release-asset@v1.0.2
+    #- uses: actions/upload-release-asset@v1.0.2
-      env:
+    #  env:
-        GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+    #    GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-      with:
+    #  with:
-        upload_url: ${{ github.event.release.upload_url }}
+    #    upload_url: ${{ github.event.release.upload_url }}
-        asset_path: dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
+    #    asset_path: dist/gf-${{ github.event.release.tag_name }}-${{ matrix.os }}.deb
-        asset_name: 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
+    #    asset_content_type: application/octet-stream
 
 # ---
 
@@ -79,16 +81,16 @@ jobs:
     name: Build macOS package
     strategy:
       matrix:
-        ghc: ["8.6.5"]
+        ghc: ["9.6"]
-        cabal: ["2.4"]
+        cabal: ["3.10"]
-        os: ["macos-10.15"]
+        os: ["macos-latest", "macos-13"]
     runs-on: ${{ matrix.os }}
 
     steps:
     - uses: actions/checkout@v2
 
     - name: Setup Haskell
-      uses: actions/setup-haskell@v1
+      uses: haskell-actions/setup@v2
       id: setup-haskell-cabal
       with:
         ghc-version: ${{ matrix.ghc }}
@@ -97,8 +99,10 @@ jobs:
     - name: Install build tools
       run: |
         brew install \
-          automake
+          automake \
+          libtool
         cabal v1-install alex happy
+        pip install setuptools
 
     - name: Build package
       run: |
@@ -107,9 +111,9 @@ jobs:
         make pkg
 
     - name: Upload artifact
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
-        name: gf-${{ github.event.release.tag_name }}-macos
+        name: gf-${{ github.event.release.tag_name }}-${{ matrix.os }}
         path: dist/gf-*.pkg
         if-no-files-found: error
 
@@ -117,14 +121,14 @@ jobs:
       run: |
         mv dist/gf-*.pkg dist/gf-${{ github.event.release.tag_name }}-macos.pkg
 
-    - uses: actions/upload-release-asset@v1.0.2
+    #- uses: actions/upload-release-asset@v1.0.2
-      env:
+    #  env:
-        GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+    #    GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-      with:
+    #  with:
-        upload_url: ${{ github.event.release.upload_url }}
+    #    upload_url: ${{ github.event.release.upload_url }}
-        asset_path: dist/gf-${{ github.event.release.tag_name }}-macos.pkg
+    #    asset_path: dist/gf-${{ github.event.release.tag_name }}-macos.pkg
-        asset_name: gf-${{ github.event.release.tag_name }}-macos.pkg
+    #    asset_name: gf-${{ github.event.release.tag_name }}-macos.pkg
-        asset_content_type: application/octet-stream
+    #    asset_content_type: application/octet-stream
 
 # ---
 
@@ -132,9 +136,9 @@ jobs:
     name: Build Windows package
     strategy:
       matrix:
-        ghc: ["8.6.5"]
+        ghc: ["9.6.7"]
-        cabal: ["2.4"]
+        cabal: ["3.10"]
-        os: ["windows-2019"]
+        os: ["windows-2022"]
     runs-on: ${{ matrix.os }}
 
     steps:
@@ -147,6 +151,7 @@ jobs:
           base-devel
           gcc
           python-devel
+          autotools
 
     - name: Prepare dist folder
       shell: msys2 {0}
@@ -171,7 +176,8 @@ jobs:
     - name: Build Java bindings
       shell: msys2 {0}
       run: |
-        export JDKPATH=/c/hostedtoolcache/windows/Java_Adopt_jdk/8.0.292-10/x64
+        echo $JAVA_HOME_8_X64
+        export JDKPATH="$(cygpath -u "${JAVA_HOME_8_X64}")"
         export PATH="${PATH}:${JDKPATH}/bin"
         cd src/runtime/java
         make \
@@ -180,6 +186,9 @@ jobs:
         make install
         cp .libs/msys-jpgf-0.dll /c/tmp-dist/java/jpgf.dll
         cp jpgf.jar /c/tmp-dist/java
+      if: false
+    
+    # - uses: actions/setup-python@v5
 
     - name: Build Python bindings
       shell: msys2 {0}
@@ -188,12 +197,13 @@ jobs:
         EXTRA_LIB_DIRS: /mingw64/lib
       run: |
         cd src/runtime/python
+        pacman --noconfirm -S python-setuptools
         python setup.py build
         python setup.py install
-        cp /usr/lib/python3.9/site-packages/pgf* /c/tmp-dist/python
+        cp -r /usr/lib/python3.12/site-packages/pgf* /c/tmp-dist/python
 
     - name: Setup Haskell
-      uses: actions/setup-haskell@v1
+      uses: haskell-actions/setup@v2
       id: setup-haskell-cabal
       with:
         ghc-version: ${{ matrix.ghc }}
@@ -205,13 +215,13 @@ jobs:
 
     - name: Build GF
       run: |
-        cabal install --only-dependencies -fserver
+        cabal install -fserver --only-dependencies 
         cabal configure -fserver
         cabal build
-        copy dist\build\gf\gf.exe C:\tmp-dist
+        copy dist-newstyle/build/x86_64-windows/ghc-${{matrix.ghc}}/*/x/gf/build/gf/gf.exe C:/tmp-dist
 
     - name: Upload artifact
-      uses: actions/upload-artifact@v2
+      uses: actions/upload-artifact@v4
       with:
         name: gf-${{ github.event.release.tag_name }}-windows
         path: C:\tmp-dist\*
@@ -220,11 +230,11 @@ jobs:
     - 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
+    #- uses: actions/upload-release-asset@v1.0.2
-      env:
+    #  env:
-        GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+    #    GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-      with:
+    #  with:
-        upload_url: ${{ github.event.release.upload_url }}
+    #    upload_url: ${{ github.event.release.upload_url }}
-        asset_path: C:\gf-${{ github.event.release.tag_name }}-windows.zip
+    #    asset_path: C:\gf-${{ github.event.release.tag_name }}-windows.zip
-        asset_name: gf-${{ github.event.release.tag_name }}-windows.zip
+    #    asset_name: gf-${{ github.event.release.tag_name }}-windows.zip
-        asset_content_type: application/zip
+    #    asset_content_type: application/zip

.github/workflows/build-python-package.yml

@@ -13,24 +13,25 @@ jobs:
     strategy:
       fail-fast: true
       matrix:
-        os: [ubuntu-18.04, macos-10.15]
+        os: [ubuntu-latest, macos-latest, macos-13]
 
     steps:
-    - uses: actions/checkout@v1
+    - uses: actions/checkout@v4
 
-    - uses: actions/setup-python@v1
+    - uses: actions/setup-python@v5
       name: Install Python
       with:
-        python-version: '3.7'
+        python-version: '3.x'
 
     - name: Install cibuildwheel
       run: |
-        python -m pip install git+https://github.com/joerick/cibuildwheel.git@main
+        python -m pip install cibuildwheel
 
     - name: Install build tools for OSX
       if: startsWith(matrix.os, 'macos')
       run: |
         brew install automake
+        brew install libtool
 
     - name: Build wheels on Linux
       if: startsWith(matrix.os, 'macos') != true
@@ -42,30 +43,32 @@ jobs:
     - name: Build wheels on OSX
       if: startsWith(matrix.os, 'macos')
       env:
-        CIBW_BEFORE_BUILD: cd src/runtime/c && glibtoolize && autoreconf -i && ./configure && make && make install
+        CIBW_BEFORE_BUILD: cd src/runtime/c && glibtoolize && autoreconf -i && ./configure && make && sudo make install
       run: |
         python -m cibuildwheel src/runtime/python --output-dir wheelhouse
 
-    - uses: actions/upload-artifact@v2
+    - uses: actions/upload-artifact@v4
       with:
+        name: wheel-${{ matrix.os }}
         path: ./wheelhouse
 
   build_sdist:
     name: Build source distribution
     runs-on: ubuntu-latest
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v4
 
-      - uses: actions/setup-python@v2
+      - uses: actions/setup-python@v5
         name: Install Python
         with:
-          python-version: '3.7'
+          python-version: '3.10'
 
       - name: Build sdist
         run: cd src/runtime/python && python setup.py sdist
 
-      - uses: actions/upload-artifact@v2
+      - uses: actions/upload-artifact@v4
         with:
+          name: wheel-source
           path: ./src/runtime/python/dist/*.tar.gz
 
   upload_pypi:
@@ -75,24 +78,25 @@ jobs:
     if: github.ref == 'refs/heads/master' && github.event_name == 'push'
 
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v4
 
       - name: Set up Python
-        uses: actions/setup-python@v2
+        uses: actions/setup-python@v5
         with:
           python-version: '3.x'
 
       - name: Install twine
         run: pip install twine
 
-      - uses: actions/download-artifact@v2
+      - uses: actions/download-artifact@v4.1.7
         with:
-          name: artifact
+          pattern: wheel-*
+          merge-multiple: true
           path: ./dist
 
       - name: Publish
         env:
           TWINE_USERNAME: __token__
-          TWINE_PASSWORD: ${{ secrets.pypi_password }}
+          TWINE_PASSWORD: ${{ secrets.PYPI_PASSWORD }}
         run: |
-          (cd ./src/runtime/python && curl -I --fail https://pypi.org/project/$(python setup.py --name)/$(python setup.py --version)/) || twine upload dist/*
+          twine upload --verbose --non-interactive --skip-existing dist/*

.gitignore

@@ -73,3 +73,9 @@ doc/icfp-2012.html
 download/*.html
 gf-book/index.html
 src/www/gf-web-api.html
+.devenv
+.direnv
+result
+.vscode
+.envrc
+.pre-commit-config.yaml

.travis.yml

@@ -1,14 +0,0 @@
-sudo: required
-
-language: c
-
-services:
-  - docker
-
-before_install:
-  - docker pull odanoburu/gf-src:3.9
-
-script:
-  - |
-    docker run --mount src="$(pwd)",target=/home/gfer,type=bind odanoburu/gf-src:3.9 /bin/bash -c "cd /home/gfer/src/runtime/c &&
-    autoreconf -i && ./configure && make && make install ; cd /home/gfer ; cabal install -fserver -fc-runtime --extra-lib-dirs='/usr/local/lib'"

CHANGELOG.md

@@ -0,0 +1,12 @@
+### New since 3.12 (WIP)
+
+### 3.12
+See <https://www.grammaticalframework.org/download/release-3.12.html>
+
+### 3.11
+
+See <https://www.grammaticalframework.org/download/release-3.11.html>
+
+### 3.10
+
+See <https://www.grammaticalframework.org/download/release-3.10.html>

Makefile

@@ -50,7 +50,7 @@ html::
 # number to the top of debian/changelog.
 # (Tested on Ubuntu 15.04. You need to install dpkg-dev & debhelper.)
 deb:
-	dpkg-buildpackage -b -uc
+	dpkg-buildpackage -b -uc -d
 
 # Make a macOS installer package
 pkg:
@@ -65,6 +65,6 @@ bintar:
 
 # Make a source tar.gz distribution using git to make sure that everything is included.
 # We put the distribution in dist/ so it is removed on `make clean`
-sdist:
+# sdist:
-	test -d dist || mkdir dist
+# 	test -d dist || mkdir dist
-	git archive --format=tar.gz --output=dist/gf-${VERSION}.tar.gz HEAD
+# 	git archive --format=tar.gz --output=dist/gf-${VERSION}.tar.gz HEAD

README.md

@@ -1,4 +1,4 @@
-![GF Logo](doc/Logos/gf1.svg)
+![GF Logo](https://www.grammaticalframework.org/doc/Logos/gf1.svg)
 
 # Grammatical Framework (GF)
 
@@ -38,8 +38,23 @@ or:
 ```
 stack install
 ```
+Note that if you are unlucky to have Cabal 3.0 or later, then it uses
+the so-called Nix style commands. Using those for GF development is
+a pain. Every time when you change something in the source code, Cabal
+will generate a new folder for GF to look for the GF libraries and
+the GF cloud. Either reinstall everything with every change in the
+compiler, or be sane and stop using cabal-install. Instead you can do:
+```
+runghc Setup.hs configure
+runghc Setup.hs build
+sudo runghc Setup.hs install
+```
+The script will install the GF dependencies globally. The only solution
+to the Nix madness that I found is radical:
 
-For more information, including links to precompiled binaries, see the [download page](http://www.grammaticalframework.org/download/index.html).
+  "No person, no problem" (Нет человека – нет проблемы).
+
+For more information, including links to precompiled binaries, see the [download page](https://www.grammaticalframework.org/download/index.html).
 
 ## About this repository
 

RELEASE.md

@@ -47,11 +47,14 @@ but the generated _artifacts_ must be manually attached to the release as _asset
 
 In order to do this you will need to be added the [GF maintainers](https://hackage.haskell.org/package/gf/maintainers/) on Hackage.
 
-1. Run `make sdist`
+1. Run `stack sdist --test-tarball` and address any issues.
 2. Upload the package, either:
-    1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file `dist/gf-X.Y.tar.gz`
+    1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file generated by the previous command.
-    2. **via Cabal (≥2.4)**: `cabal upload dist/gf-X.Y.tar.gz`
+    2. **via Stack**: `stack upload . --candidate`
-3. If the documentation-building fails on the Hackage server, do:
+3. After testing the candidate, publish it:
+    1. **Manually**: visit <https://hackage.haskell.org/package/gf-X.Y.Z/candidate/publish>
+    1. **via Stack**: `stack upload .`
+4. If the documentation-building fails on the Hackage server, do:
 ```
 cabal v2-haddock --builddir=dist/docs --haddock-for-hackage --enable-doc
 cabal upload --documentation dist/docs/*-docs.tar.gz

Setup.hs

@@ -4,42 +4,68 @@ import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs
 import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..),SDistFlags(..))
 import Distribution.PackageDescription(PackageDescription(..),emptyHookedBuildInfo)
 import Distribution.Simple.BuildPaths(exeExtension)
+import System.Directory
 import System.FilePath((</>),(<.>))
+import System.Process
+import Control.Monad(forM_,unless)
+import Control.Exception(bracket_)
+import Data.Char(isSpace)
 
 import WebSetup
 
--- | Notice about RGL not built anymore
-noRGLmsg :: IO ()
-noRGLmsg = putStrLn "Notice: the RGL is not built as part of GF anymore. See https://github.com/GrammaticalFramework/gf-rgl"
-
 main :: IO ()
 main = defaultMainWithHooks simpleUserHooks
-  { preBuild  = gfPreBuild
+  { preConf   = gfPreConf
+  , preBuild  = gfPreBuild
   , postBuild = gfPostBuild
   , preInst   = gfPreInst
   , postInst  = gfPostInst
   , postCopy  = gfPostCopy
   }
   where
-    gfPreBuild args  = gfPre args . buildDistPref
+    gfPreConf args flags = do
-    gfPreInst args = gfPre args . installDistPref
+      pkgs <- fmap (map (dropWhile isSpace) . tail . lines)
+                   (readProcess "ghc-pkg" ["list"] "")
+      forM_ dependencies $ \pkg -> do
+        let name = takeWhile (/='/') (drop 36 pkg)
+        unless (name `elem` pkgs) $ do
+          let fname = name <.> ".tar.gz"
+          callProcess "wget" [pkg,"-O",fname]
+          callProcess "tar"  ["-xzf",fname]
+          removeFile fname
+          bracket_ (setCurrentDirectory name) (setCurrentDirectory ".." >> removeDirectoryRecursive name) $ do
+            exists <- doesFileExist "Setup.hs"
+            unless exists $ do
+              writeFile "Setup.hs" (unlines [
+                  "import Distribution.Simple",
+                  "main = defaultMain"
+                ])
+            let to_descr = reverse .
+                           (++) (reverse ".cabal") . 
+                           drop 1 . 
+                           dropWhile (/='-') . 
+                           reverse
+            callProcess "wget"   [to_descr pkg, "-O", to_descr name]
+            callProcess "runghc" ["Setup.hs","configure"]
+            callProcess "runghc" ["Setup.hs","build"]
+            callProcess "sudo" ["runghc","Setup.hs","install"]
+          
+      preConf simpleUserHooks args flags
+
+    gfPreBuild args = gfPre args . buildDistPref
+    gfPreInst  args = gfPre args . installDistPref
 
     gfPre args distFlag = do
       return emptyHookedBuildInfo
 
     gfPostBuild args flags pkg lbi = do
-      -- noRGLmsg
       let gf = default_gf lbi
       buildWeb gf flags (pkg,lbi)
 
     gfPostInst args flags pkg lbi = do
-      -- noRGLmsg
-      saveInstallPath args flags (pkg,lbi)
       installWeb (pkg,lbi)
 
     gfPostCopy args flags  pkg lbi = do
-      -- noRGLmsg
-      saveCopyPath args flags (pkg,lbi)
       copyWeb flags (pkg,lbi)
 
     -- `cabal sdist` will not make a proper dist archive, for that see `make sdist`
@@ -47,27 +73,16 @@ main = defaultMainWithHooks simpleUserHooks
     gfSDist pkg lbi hooks flags = do
       return ()
 
-saveInstallPath :: [String] -> InstallFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
+dependencies = [
-saveInstallPath args flags bi = do
+  "https://hackage.haskell.org/package/utf8-string-1.0.2/utf8-string-1.0.2.tar.gz",
-  let
+  "https://hackage.haskell.org/package/json-0.10/json-0.10.tar.gz",
-    dest = NoCopyDest
+  "https://hackage.haskell.org/package/network-bsd-2.8.1.0/network-bsd-2.8.1.0.tar.gz",
-    dir = datadir (uncurry absoluteInstallDirs bi dest)
+  "https://hackage.haskell.org/package/httpd-shed-0.4.1.1/httpd-shed-0.4.1.1.tar.gz",
-  writeFile dataDirFile dir
+  "https://hackage.haskell.org/package/exceptions-0.10.5/exceptions-0.10.5.tar.gz",
-
+  "https://hackage.haskell.org/package/stringsearch-0.3.6.6/stringsearch-0.3.6.6.tar.gz",
-saveCopyPath :: [String] -> CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
+  "https://hackage.haskell.org/package/multipart-0.2.1/multipart-0.2.1.tar.gz",
-saveCopyPath args flags bi = do
+  "https://hackage.haskell.org/package/cgi-3001.5.0.0/cgi-3001.5.0.0.tar.gz"
-  let
+  ]
-    dest = case copyDest flags of
-      NoFlag -> NoCopyDest
-      Flag d -> d
-    dir = datadir (uncurry absoluteInstallDirs bi dest)
-  writeFile dataDirFile dir
-
--- | Name of file where installation's data directory is recording
--- This is a last-resort way in which the seprate RGL build script
--- can determine where to put the compiled RGL files
-dataDirFile :: String
-dataDirFile = "DATA_DIR"
 
 -- | Get path to locally-built gf
 default_gf :: LocalBuildInfo -> FilePath

bin/build-binary-dist.sh

@@ -32,7 +32,7 @@ set -x                             # print commands before executing them
 pushd src/runtime/c
 bash setup.sh configure --prefix="$prefix"
 bash setup.sh build
-bash setup.sh install prefix="$prefix" # hack required for GF build on macOS
+# bash setup.sh install prefix="$prefix" # hack required for GF build on macOS
 bash setup.sh install prefix="$destdir$prefix"
 popd
 
@@ -46,7 +46,7 @@ if which >/dev/null python; then
         pyver=$(ls "$destdir$prefix/lib" | sed -n 's/^python//p')
         pydest="$destdir/Library/Python/$pyver/site-packages"
         mkdir -p "$pydest"
-        ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf* "$pydest"
+        ln "$destdir$prefix/lib/python$pyver/site-packages"/pgf*.so "$pydest"
     fi
     popd
 else

debian/changelog

@@ -1,3 +1,8 @@
+gf (3.12) noble; urgency=low
+
+  * GF 3.12
+
+ -- Inari Listenmaa <inari@digitalgrammars.com>  Fri, 8 Aug 2025 18:29:29 +0100
 gf (3.11) bionic focal; urgency=low
 
   * GF 3.11

debian/control

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

debian/rules

@@ -16,7 +16,7 @@ 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 v1-update
+	cabal 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
 
@@ -24,7 +24,7 @@ SET_LDL=LD_LIBRARY_PATH=$$LD_LIBRARY_PATH:$(CURDIR)/src/runtime/c/.libs
 
 override_dh_auto_build:
 	cd src/runtime/python && EXTRA_INCLUDE_DIRS=$(CURDIR)/src/runtime/c EXTRA_LIB_DIRS=$(CURDIR)/src/runtime/c/.libs python setup.py build
-	cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr
+	# cd src/runtime/java && make CFLAGS="-I$(CURDIR)/src/runtime/c -L$(CURDIR)/src/runtime/c/.libs" INSTALL_PATH=/usr
 	echo $(SET_LDL)
 	-$(SET_LDL) cabal v1-build
 
@@ -32,13 +32,15 @@ override_dh_auto_install:
 	$(SET_LDL) cabal v1-copy --destdir=$(CURDIR)/debian/gf
 	cd src/runtime/c && bash setup.sh copy prefix=$(CURDIR)/debian/gf/usr
 	cd src/runtime/python && python setup.py install --prefix=$(CURDIR)/debian/gf/usr
-	cd src/runtime/java && make INSTALL_PATH=$(CURDIR)/debian/gf/usr install
+	# cd src/runtime/java && make INSTALL_PATH=$(CURDIR)/debian/gf/usr install
-	D="`find debian/gf -name site-packages`" && [ -n "$$D" ] && cd $$D && cd .. && mv site-packages dist-packages
+	# D="`find debian/gf -name dist-packages`" && [ -n "$$D" ] && cd $$D && cd .. && mv dist-packages dist-packages
+
+override_dh_usrlocal:
 
 override_dh_auto_clean:
 	rm -fr dist/build
 	-cd src/runtime/python && rm -fr build
-	-cd src/runtime/java && make clean
+	# -cd src/runtime/java && make clean
 	-cd src/runtime/c && make clean
 
 override_dh_auto_test:

doc/gf-developers.t2t

@@ -150,11 +150,9 @@ Open a terminal, go to the top directory (``gf-core``), and type the following c
 $ 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.
+
+If you prefer Cabal, then you just need to manually choose a suitable GHC to build GF. We recommend GHC 9.6.7, see other supported options in [gf.cabal https://github.com/GrammaticalFramework/gf-core/blob/master/gf.cabal#L14].
 
 The actual installation process is similar to Stack: open a terminal, go to the top directory (``gf-core``), and type the following command.
 
@@ -162,7 +160,13 @@ The actual installation process is similar to Stack: open a terminal, go to the
 $ cabal install
 ```
 
-//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.//
+=== Nix ===
+
+As of 3.12, GF can also be installed via Nix. You can install GF from github with the following command:
+
+```
+nix profile install github:GrammaticalFramework/gf-core#gf
+```
 
 == Compiling GF with C runtime system support ==
 
@@ -197,7 +201,7 @@ Depending on what you want to do with the C runtime, you can follow one or more
 
 === 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.**
+% **If you just want to use the C runtime from Python or Haskell, you don't need to change your GF installation.**
 
 - **What —**
 This is the most common use case for the C runtime: compile
@@ -230,20 +234,13 @@ 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].
+but if you want Python 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:
 
-```
+Add (or uncomment) the following lines in the ``stack.yaml`` file:
-cabal install -fc-runtime
-```
-
-from the top directory (``gf-core``).
-
-If you use stack, uncomment the following lines in the ``stack.yaml`` file:
 
 ```
 flags:
@@ -254,6 +251,32 @@ extra-lib-dirs:
 ```
 and then run ``stack install`` from the top directory (``gf-core``).
 
+Run the newly built executable with the flag ``-cshell``, and you should see the following welcome message:
+
+```
+$ gf -cshell
+
+         *  *  *
+      *           *
+    *               *
+   *
+   *
+   *        * * * * * *
+   *        *         *
+    *       * * * *  *
+      *     *      *
+         *  *  *
+
+This is GF version 3.12.0.
+Built on ...
+Git info: ...
+
+Flags: interrupt server c-runtime
+License: see help -license.
+
+This shell uses the C run-time system. See help for available commands.
+>
+```
 
 //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.//
@@ -266,14 +289,8 @@ With this feature, ``gf -server`` mode is extended with new requests to call the
 system, e.g. ``c-parse``, ``c-linearize`` and ``c-translate``.
 
 - **How —**
-If you use cabal, run the following command:
 
-```
+Add the following lines in the ``stack.yaml`` file:
-cabal install -fc-runtime -fserver
-```
-from the top directory.
-
-If you use stack, add the following lines in the ``stack.yaml`` file:
 
 ```
 flags:

doc/gf-editor-modes.md

@@ -0,0 +1,75 @@
+# Editor modes & IDE integration for GF
+
+We collect GF modes for various editors on this page. Contributions are welcome!
+
+## Emacs
+
+[gf.el](https://github.com/GrammaticalFramework/gf-emacs-mode) by Johan
+Bockgård provides syntax highlighting and automatic indentation and
+lets you run the GF Shell in an emacs buffer.  See installation
+instructions inside.
+
+## Atom
+
+[language-gf](https://atom.io/packages/language-gf), by John J. Camilleri
+
+## Visual Studio Code
+
+* [Grammatical Framework Language Server](https://marketplace.visualstudio.com/items?itemName=anka-213.gf-vscode) by Andreas Källberg.
+This provides syntax highlighting and a client for the Grammatical Framework language server. Follow the installation instructions in the link.
+* [Grammatical Framework](https://marketplace.visualstudio.com/items?itemName=GrammaticalFramework.gf-vscode) is a simpler extension
+without any external dependencies which provides only syntax highlighting.
+
+## Eclipse
+
+[GF Eclipse Plugin](https://github.com/GrammaticalFramework/gf-eclipse-plugin/), by John J. Camilleri
+
+## Gedit
+
+By John J. Camilleri
+
+Copy the file below to
+`~/.local/share/gtksourceview-3.0/language-specs/gf.lang` (under Ubuntu).
+
+ * [gf.lang](../src/tools/gf.lang)
+
+Some helpful notes/links:
+
+ * The code is based heavily on the `haskell.lang` file which I found in
+`/usr/share/gtksourceview-2.0/language-specs/haskell.lang`.
+ * Ruslan Osmanov recommends
+[registering your file extension as its own MIME type](http://osmanov-dev-notes.blogspot.com/2011/04/how-to-add-new-highlight-mode-in-gedit.html)
+(see also [here](https://help.ubuntu.com/community/AddingMimeTypes)),
+however on my system the `.gf` extension was already registered
+as a generic font (`application/x-tex-gf`) and I didn't want to risk
+messing any of that up.
+ * This is a quick 5-minute job and might require some tweaking.
+[The GtkSourceView language definition tutorial](http://developer.gnome.org/gtksourceview/stable/lang-tutorial.html)
+is the place to start looking.
+ * Contributions are welcome!
+
+## Geany
+
+By John J. Camilleri
+
+[Custom filetype](http://www.geany.org/manual/dev/index.html#custom-filetypes)
+config files for syntax highlighting in [Geany](http://www.geany.org/).
+
+For version 1.36 and above, copy one of the files below to
+`/usr/share/geany/filedefs/filetypes.GF.conf` (under Ubuntu).
+If you're using a version older than 1.36, copy the file to `/usr/share/geany/filetypes.GF.conf`.
+You will need to manually create the file.
+
+ * [light-filetypes.GF.conf](../src/tools/light-filetypes.GF.conf)
+ * [dark-filetypes.GF.conf](../src/tools/dark-filetypes.GF.conf)
+
+You will also need to edit the `filetype_extensions.conf` file and add the
+following line somewhere:
+
+```
+GF=*.gf
+```
+
+## Vim
+
+[vim-gf](https://github.com/gdetrez/vim-gf)

doc/gf-editor-modes.t2t

@@ -1,78 +0,0 @@
-Editor modes & IDE integration for GF
-
-
-We collect GF modes for various editors on this page. Contributions are
-welcome!
-
-
-==Emacs==
-
-[gf.el https://github.com/GrammaticalFramework/gf-emacs-mode] by Johan
-Bockgård provides syntax highlighting and automatic indentation and
-lets you run the GF Shell in an emacs buffer.  See installation
-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
-
-==Gedit==
-
-By John J. Camilleri
-
-Copy the file below to
-``~/.local/share/gtksourceview-3.0/language-specs/gf.lang`` (under Ubuntu).
-
-- [gf.lang ../src/tools/gf.lang]
-
-
-Some helpful notes/links:
-
-- The code is based heavily on the ``haskell.lang`` file which I found in
-  ``/usr/share/gtksourceview-2.0/language-specs/haskell.lang``.
-- Ruslan Osmanov recommends
-  [registering your file extension as its own MIME type http://osmanov-dev-notes.blogspot.com/2011/04/how-to-add-new-highlight-mode-in-gedit.html]
-  (see also [here https://help.ubuntu.com/community/AddingMimeTypes]),
-  however on my system the ``.gf`` extension was already registered
-  as a generic font (``application/x-tex-gf``) and I didn't want to risk
-  messing any of that up.
-- This is a quick 5-minute job and might require some tweaking.
-  [The GtkSourceView language definition tutorial http://developer.gnome.org/gtksourceview/stable/lang-tutorial.html]
-  is the place to start looking.
-- Contributions are welcome!
-
-
-==Geany==
-
-By John J. Camilleri
-
-[Custom filetype http://www.geany.org/manual/dev/index.html#custom-filetypes]
-config files for syntax highlighting in [Geany http://www.geany.org/].
-
-Copy one of the files below to ``/usr/share/geany/filetypes.GF.conf``
-(under Ubuntu). You will need to manually create the file.
-
-- [light-filetypes.GF.conf ../src/tools/light-filetypes.GF.conf]
-- [dark-filetypes.GF.conf ../src/tools/dark-filetypes.GF.conf]
-
-
-You will also need to edit the ``filetype_extensions.conf`` file and add the
-following line somewhere:
-
-```
-GF=*.gf
-```
-
-
-==Vim==
-
-[vim-gf https://github.com/gdetrez/vim-gf]

doc/gf-help-full.txt

@@ -303,7 +303,7 @@ but the resulting .gf file must be imported separately.
 
 #TINY
 
-Generates a list of random trees, by default one tree.
+Generates a list of random trees, by default one tree up to depth 5.
 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.
@@ -315,13 +315,14 @@ given in a file in the -probs flag.
  | ``-cat`` | generation category
  | ``-lang`` | uses only functions that have linearizations in all these languages
  | ``-number`` | number of trees generated
- | ``-depth`` | the maximum generation depth
+ | ``-depth`` | the maximum generation depth (default: 5)
  | ``-probs`` | file with biased probabilities (format 'f 0.4' one by line)
 
 - Examples:
 
  | ``gr`` | one tree in the startcat of the current grammar
  | ``gr -cat=NP -number=16`` | 16 trees in the category NP
+ | ``gr -cat=NP -depth=2`` | one tree in the category NP, up to depth 2
  | ``gr -lang=LangHin,LangTha -cat=Cl`` | Cl, both in LangHin and LangTha
  | ``gr -probs=FILE`` | generate with bias
  | ``gr (AdjCN ? (UseN ?))`` | generate trees of form (AdjCN ? (UseN ?))
@@ -339,7 +340,7 @@ given in a file in the -probs flag.
 #TINY
 
 Generates all trees of a given category. By default,
-the depth is limited to 4, but this can be changed by a flag.
+the depth is limited to 5, but this can be changed by a flag.
 If a Tree argument is given, the command completes the Tree with values
 to all metavariables in the tree.
 
@@ -353,7 +354,7 @@ to all metavariables in the tree.
 
 - Examples:
 
- | ``gt`` | all trees in the startcat, to depth 4
+ | ``gt`` | all trees in the startcat, to depth 5
  | ``gt -cat=NP -number=16`` | 16 trees in the category NP
  | ``gt -cat=NP -depth=2`` | trees in the category NP to depth 2
  | ``gt (AdjCN ? (UseN ?))`` | trees of form (AdjCN ? (UseN ?))

doc/gf-people.md

@@ -7,7 +7,6 @@ title: "Grammatical Framework: Authors and Acknowledgements"
 The current maintainers of GF are
 
 [Krasimir Angelov](http://www.chalmers.se/cse/EN/organization/divisions/computing-science/people/angelov-krasimir),
-[Thomas Hallgren](http://www.cse.chalmers.se/~hallgren/),
 [Aarne Ranta](http://www.cse.chalmers.se/~aarne/),
 [John J. Camilleri](http://johnjcamilleri.com), and
 [Inari Listenmaa](https://inariksit.github.io/).
@@ -22,6 +21,7 @@ and
 
 The following people have contributed code to some of the versions:
 
+- [Thomas Hallgren](http://www.cse.chalmers.se/~hallgren/) (University of Gothenburg)
 - Grégoire Détrez (University of Gothenburg)
 - Ramona Enache (University of Gothenburg)
 - [Björn Bringert](http://www.cse.chalmers.se/alumni/bringert) (University of Gothenburg)

doc/tutorial/gf-tutorial.t2t

@@ -1188,7 +1188,7 @@ use ``generate_trees = gt``.
   this wine is fresh
   this wine is warm
 ```
-The default **depth** is 3; the depth can be
+The default **depth** is 5; the depth can be
 set by using the ``depth`` flag:
 ```
   > generate_trees -depth=2 | l
@@ -1265,10 +1265,16 @@ Human eye may prefer to see a visualization: ``visualize_tree = vt``:
   > parse "this delicious cheese is very Italian" | visualize_tree
 ```
 The tree is generated in postscript (``.ps``) file. The ``-view`` option is used for
-telling what command to use to view the file. Its default is ``"open"``, which works
+telling what command to use to view the file.
-on Mac OS X. On Ubuntu Linux, one can write
+
+This works on Mac OS X:
 ```
-  > parse "this delicious cheese is very Italian" | visualize_tree -view="eog"
+  > parse "this delicious cheese is very Italian" | visualize_tree -view=open
+```
+On Linux, one can use one of the following commands.
+```
+  > parse "this delicious cheese is very Italian" | visualize_tree -view=eog
+  > parse "this delicious cheese is very Italian" | visualize_tree -view=xdg-open
 ```
 
 
@@ -1733,6 +1739,13 @@ A new module can **extend** an old one:
       Pizza : Kind ;
   }
 ```
+Note that the extended grammar doesn't inherit the start
+category from the grammar it extends, so if you want to
+generate sentences with this grammar, you'll have to either
+add a startcat (e.g. ``flags startcat = Question ;``),
+or in the GF shell, specify the category to ``generate_random`` or ``geneate_trees``
+(e.g. ``gr -cat=Comment`` or ``gt -cat=Question``).
+
 Parallel to the abstract syntax, extensions can
 be built for concrete syntaxes:
 ```
@@ -4578,7 +4591,7 @@ in any multilingual grammar between any languages in the grammar.
 module Main where
 
 import PGF
-import System (getArgs)
+import System.Environment (getArgs)
 
 main :: IO ()
 main = do

download/index-3.11.md

@@ -53,26 +53,39 @@ 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 from Hackage
+
+_Instructions applicable for macOS, Linux, and WSL2 on Windows._
 
 [GF is on Hackage](http://hackage.haskell.org/package/gf), so under
 normal circumstances the procedure is fairly simple:
 
-1.  Install ghcup https://www.haskell.org/ghcup/
+```
-2.  `ghcup install ghc 8.10.4`
+cabal update
-3.  `ghcup set ghc 8.10.4`
+cabal install gf-3.11
-4.  `cabal update`
+```
-5.  On Linux: install some C libraries from your Linux distribution (see note below)
-6.  `cabal install gf-3.11`
-
-You can also download the source code release from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases),
-and follow the instructions below under **Installing from the latest developer source code**.
 
 ### Notes
 
+**GHC version**
+
+The GF source code is known to be compilable with GHC versions 7.10 through to 8.10.
+
+**Obtaining Haskell**
+
+There are various ways of obtaining Haskell, including:
+
+- ghcup
+    1.  Install from https://www.haskell.org/ghcup/
+    2.  `ghcup install ghc 8.10.4`
+    3.  `ghcup set ghc 8.10.4`
+- Haskell Platform https://www.haskell.org/platform/
+- Stack https://haskellstack.org/
+
+
 **Installation location**
 
-The above steps installs GF for a single user.
+The above steps install GF for a single user.
 The executables are put in `$HOME/.cabal/bin` (or on macOS in `$HOME/Library/Haskell/bin`),
 so you might want to add this directory to your path (in `.bash_profile` or similar):
 
@@ -84,32 +97,34 @@ PATH=$HOME/.cabal/bin:$PATH
 
 GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which
 on Linux depends on some non-Haskell libraries that won't be installed
-automatically by cabal, and therefore need to be installed manually.
+automatically by Cabal, and therefore need to be installed manually.
 Here is one way to do this:
 
 - On Ubuntu: `sudo apt-get install libghc-haskeline-dev`
 - On Fedora: `sudo dnf install ghc-haskeline-devel`
 
-**GHC version**
+## Installing from source code
 
-The GF source code has been updated to compile with GHC versions 7.10 through to 8.8.
+**Obtaining**
--->
-## Installing from the latest developer source code
 
-If you haven't already, clone the repository with:
+To obtain the source code for the **release**,
+download it from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases).
 
+Alternatively, to obtain the **latest version** of the source code:
+
+1. If you haven't already, clone the repository with:
 ```
 git clone https://github.com/GrammaticalFramework/gf-core.git
 ```
-
+2. If you've already cloned the repository previously, update with:
-If you've already cloned the repository previously, update with:
-
 ```
 git pull
 ```
 
-Then install with:
 
+**Installing**
+
+You can then install with:
 ```
 cabal install
 ```
@@ -124,6 +139,8 @@ stack install
 For more info on working with the GF source code, see the
 [GF Developers Guide](../doc/gf-developers.html).
 
+For macOS Sequoia, you need to downgrade the LLVM package, see instructions [here](https://github.com/GrammaticalFramework/gf-core/issues/172#issuecomment-2599365457).
+
 ## Installing the Python bindings from PyPI
 
 The Python library is available on PyPI as `pgf`, so it can be installed using:

download/index-3.12.md

@@ -0,0 +1,191 @@
+---
+title: Grammatical Framework Download and Installation
+date: 8 August 2025
+---
+
+**GF 3.12** was released on 8 August 2025.
+
+What's new? See the [release notes](release-3.12.html).
+
+#### Note: GF core and the RGL
+
+The following instructions explain how to install **GF core**, i.e. the compiler, shell and run-time systems.
+Obtaining the **Resource Grammar Library (RGL)** is done separately; see the section [at the bottom of this page](#installing-the-rgl-from-a-binary-release).
+
+---
+
+## Installing from a binary package
+
+Binary packages are available for Debian/Ubuntu, macOS, and Windows and include:
+
+- GF shell and grammar compiler
+- `gf -server` mode
+- C run-time system
+- Python bindings to the C run-time system
+
+[Binary packages on GitHub](https://github.com/GrammaticalFramework/gf-core/releases/tag/3.12)
+
+#### Debian/Ubuntu
+
+The package targets Ubuntu 24.04 (Noble).
+To install it, use:
+
+```
+sudo apt install ./gf-3.12-ubuntu-24.04.deb 
+```
+
+#### macOS
+
+If you are on an Intel Mac (2019 or older), use `gf-3.12-macos-intel.pkg`.<br>
+For newer ARM-based Macs (Apple Silicon M1, M2, M3), use `gf-3.12-macos-arm.pkg`.
+
+After downloading, right click on the file and click on Open.[^1]
+You will see a dialog saying that "macOS cannot verify the developer of "gf-3.12-macos-intel.pkg". Are you sure you want to open it?". 
+Press Open.
+
+[^1]: If you just double click on the file, you will get an error message "gf-3.12-macos-intel.pkg" cannot be opened because it is from an unidentified developer.
+
+#### Windows
+
+To install the package:
+
+1. unpack it anywhere and take note of the full path to the folder containing the `.exe` file. 
+2. add it to the `PATH` environment variable
+
+For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10).
+
+## Installing from Hackage
+
+_Instructions applicable for macOS, Linux, and WSL2 on Windows._
+
+[GF is on Hackage](http://hackage.haskell.org/package/gf), so under
+normal circumstances the procedure is fairly simple:
+
+```
+cabal update
+cabal install gf-3.12
+```
+
+### Notes
+
+#### GHC version
+
+The GF source code is known to be compilable with GHC versions 7.10 through to 9.6.7.
+
+#### Obtaining Haskell
+
+There are various ways of obtaining Haskell, including:
+
+- ghcup
+    1. Install from https://www.haskell.org/ghcup/
+    2. `ghcup install ghc 9.6.7`
+    3. `ghcup set ghc 9.6.7`
+- Stack: https://haskellstack.org/
+
+
+#### Installation location
+
+The above steps install GF for a single user.
+The executables are put in `$HOME/.cabal/bin` (or on macOS in `$HOME/Library/Haskell/bin`),
+so you might want to add this directory to your path (in `.bash_profile` or similar):
+
+```
+PATH=$HOME/.cabal/bin:$PATH
+```
+
+#### Haskeline
+
+GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which
+on Linux depends on some non-Haskell libraries that won't be installed
+automatically by Cabal, and therefore need to be installed manually.
+Here is one way to do this:
+
+- On Ubuntu: `sudo apt-get install libghc-haskeline-dev`
+- On Fedora: `sudo dnf install ghc-haskeline-devel`
+
+## Installing from source code
+
+### Obtaining
+
+To obtain the source code for the **release**,
+download it from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases).
+
+Alternatively, to obtain the **latest version** of the source code:
+
+1. If you haven't already, clone the repository with:
+```
+git clone https://github.com/GrammaticalFramework/gf-core.git
+```
+2. If you've already cloned the repository previously, update with:
+```
+git pull
+```
+
+### Installing
+
+You can then install with:
+```
+cabal install
+```
+
+or, if you're a Stack user:
+
+```
+stack install
+```
+
+<!--The above notes for installing from source apply also in these cases.-->
+For more info on working with the GF source code, see the
+[GF Developers Guide](../doc/gf-developers.html).
+
+## Installing the Python bindings from PyPI
+
+The Python library is available on PyPI as `pgf`, so it can be installed using:
+
+```
+pip install pgf
+```
+
+If this doesn't work, you will need to install the C runtime manually; see the instructions [here](https://www.grammaticalframework.org/doc/gf-developers.html#toc12).
+
+---
+
+## Installing the RGL from a binary release
+
+Binary releases of the RGL are made available on [GitHub](https://github.com/GrammaticalFramework/gf-rgl/releases).
+In general the steps to follow are:
+
+1. Download a binary release and extract it somewhere on your system.
+2. Set the environment variable `GF_LIB_PATH` to point to wherever you extracted the RGL.
+
+For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10).
+
+## Installing the RGL from source
+
+To compile the RGL, you will need to have GF already installed and in your path.
+
+1. Obtain the RGL source code, either by:
+  - cloning with `git clone https://github.com/GrammaticalFramework/gf-rgl.git`
+  - downloading a source archive [here](https://github.com/GrammaticalFramework/gf-rgl/archive/master.zip)
+2. Run `make` in the source code folder.
+
+For more options, see the [RGL README](https://github.com/GrammaticalFramework/gf-rgl/blob/master/README.md).
+
+---
+
+## Older releases
+
+- [GF 3.11](index-3.11.html) (July 2021)
+- [GF 3.10](index-3.10.html) (December 2018)
+- [GF 3.9](index-3.9.html) (August 2017)
+- [GF 3.8](index-3.8.html) (June 2016)
+- [GF 3.7.1](index-3.7.1.html) (October 2015)
+- [GF 3.7](index-3.7.html) (June 2015)
+- [GF 3.6](index-3.6.html) (June 2014)
+- [GF 3.5](index-3.5.html) (August 2013)
+- [GF 3.4](index-3.4.html) (January 2013)
+- [GF 3.3.3](index-3.3.3.html) (March 2012)
+- [GF 3.3](index-3.3.html) (October 2011)
+- [GF 3.2.9](index-3.2.9.html) source-only snapshot (September 2011)
+- [GF 3.2](index-3.2.html) (December 2010)
+- [GF 3.1.6](index-3.1.6.html) (April 2010)

download/index.html

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

download/release-3.12.md

@@ -0,0 +1,37 @@
+---
+title: GF 3.12 Release Notes
+date: 08 August 2025
+---
+
+## Installation
+
+See the [download page](index-3.12.html).
+
+## What's new
+This release adds support for Apple Silicon M1 Mac computers and newer versions of GHC, along with various improvements and bug fixes.
+
+Over 70 commits have been merged to gf-core since the release of GF 3.11 in July 2021.
+
+## General
+- Support for ARM, allowing to run GF on Mac computers with Apple Silicon M1
+- Support for newer versions of GHC (8.10.7, 9.0.2, 9.2.4, 9.4, 9.6.7)
+- Support compiling with Nix
+- Better error messages
+- Improvements to several GF shell commands
+- Several bug fixes and performance improvements
+- Temporarily dropped support for Java bindings
+
+## GF compiler and run-time library
+- Syntactic sugar for table update: `table {cases ; vvv => t \! vvv}.t` can now be written as `t ** { cases }`  
+- Adjust the `-view` command depending on the OS
+- Improve output of the `visualize_dependencies` (`vd`) command for large dependency trees
+- Reintroduce syntactic transfer with `pt -transfer` and fix a bug in `pt -compute`
+- Bug fix: apply `gt` to all arguments when piped
+- Fix many "Invalid character" messages by always encoding GF files in UTF-8
+- Improve performance with long extend-lists
+- Improve syntax error messages
+- Add support for BIND tokens in the Python bindings
+- Allow compilation with emscripten
+
+## Other
+- Add support for Visual Studio Code

flake.lock

@@ -0,0 +1,43 @@
+{
+  "nodes": {
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1704290814,
+        "narHash": "sha256-LWvKHp7kGxk/GEtlrGYV68qIvPHkU9iToomNFGagixU=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "70bdadeb94ffc8806c0570eb5c2695ad29f0e421",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixos-23.05",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "nixpkgs": "nixpkgs",
+        "systems": "systems"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,50 @@
+{
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs/nixos-23.05";
+    systems.url = "github:nix-systems/default";
+  };
+
+  nixConfig = {
+    # extra-trusted-public-keys =
+    #   "devenv.cachix.org-1:w1cLUi8dv3hnoSPGAuibQv+f9TZLr6cv/Hm9XgU50cw=";
+    # extra-substituters = "https://devenv.cachix.org";
+  };
+
+  outputs = { self, nixpkgs, systems, ... }@inputs:
+    let forEachSystem = nixpkgs.lib.genAttrs (import systems);
+    in {
+      packages = forEachSystem (system:
+        let
+          pkgs = nixpkgs.legacyPackages.${system};
+          haskellPackages = pkgs.haskell.packages.ghc925.override {
+            overrides = self: _super: {
+              cgi = pkgs.haskell.lib.unmarkBroken (pkgs.haskell.lib.dontCheck
+                (self.callHackage "cgi" "3001.5.0.1" { }));
+            };
+          };
+
+        in {
+          gf = pkgs.haskell.lib.overrideCabal
+            (haskellPackages.callCabal2nixWithOptions "gf" self "--flag=-server"
+              { }) (_old: {
+                # Fix utf8 encoding problems
+                patches = [
+                  # Already applied in master
+                  # (
+                  #   pkgs.fetchpatch {
+                  #     url = "https://github.com/anka-213/gf-core/commit/6f1ca05fddbcbc860898ddf10a557b513dfafc18.patch";
+                  #     sha256 = "17vn3hncxm1dwbgpfmrl6gk6wljz3r28j191lpv5zx741pmzgbnm";
+                  #   }
+                  # )
+                  ./nix/expose-all.patch
+                  ./nix/revert-new-cabal-madness.patch
+                ];
+                jailbreak = true;
+                # executableSystemDepends = [
+                #   (pkgs.ncurses.override { enableStatic = true; })
+                # ];
+                # executableHaskellDepends = [ ];
+              });
+        });
+    };
+}

gf-book/examples/chapter2/FoodIta.gf

@@ -2,7 +2,7 @@ concrete FoodIta of Food = {
   lincat
     Comment, Item, Kind, Quality = Str ;
   lin
-    Pred item quality = item ++ "è" ++ quality ;
+    Pred item quality = item ++ "è" ++ quality ;
     This kind = "questo" ++ kind ;
     That kind = "quel" ++ kind ;
     Mod quality kind = kind ++ quality ;

gf-book/examples/chapter3/ResIta.gf

@@ -32,5 +32,5 @@ resource ResIta = open Prelude in {
       in 
       adjective nero (ner+"a") (ner+"i") (ner+"e") ;
     copula : Number => Str = 
-      table {Sg => "è" ; Pl => "sono"} ;
+      table {Sg => "è" ; Pl => "sono"} ;
 }

gf-book/examples/chapter5/LexFoodsFin.gf

@@ -9,12 +9,12 @@ instance LexFoodsFin of LexFoods =
     fish_N = mkN "kala" ;
     fresh_A = mkA "tuore" ;
     warm_A = mkA
-    (mkN "lämmin" "lämpimän" "lämmintä" "lämpimänä" "lämpimään" 
+    (mkN "lämmin" "lämpimän" "lämmintä" "lämpimänä" "lämpimään"
-         "lämpiminä" "lämpimiä" "lämpimien" "lämpimissä" "lämpimiin"
+         "lämpiminä" "lämpimiä" "lämpimien" "lämpimissä" "lämpimiin"
 	 )
-    "lämpimämpi" "lämpimin" ;
+    "lämpimämpi" "lämpimin" ;
     italian_A = mkA "italialainen" ;
     expensive_A = mkA "kallis" ;
     delicious_A = mkA "herkullinen" ;
-    boring_A = mkA "tylsä" ;
+    boring_A = mkA "tylsä" ;
 }

gf-book/examples/chapter5/LexFoodsGer.gf

@@ -5,12 +5,12 @@ instance LexFoodsGer of LexFoods =
   oper
     wine_N = mkN "Wein" ;
     pizza_N = mkN "Pizza" "Pizzen" feminine ;
-    cheese_N = mkN "Käse" "Käse" masculine ;
+    cheese_N = mkN "Käse" "Käse" masculine ;
     fish_N = mkN "Fisch" ;
     fresh_A = mkA "frisch" ;
-    warm_A = mkA "warm" "wärmer" "wärmste" ;
+    warm_A = mkA "warm" "wärmer" "wärmste" ;
     italian_A = mkA "italienisch" ;
     expensive_A = mkA "teuer" ;
-    delicious_A = mkA "köstlich" ;
+    delicious_A = mkA "köstlich" ;
     boring_A = mkA "langweilig" ;
 }

gf-book/examples/chapter5/LexFoodsSwe.gf

@@ -7,10 +7,10 @@ instance LexFoodsSwe of LexFoods =
     pizza_N = mkN "pizza" ;
     cheese_N = mkN "ost" ;
     fish_N = mkN "fisk" ;
-    fresh_A = mkA "färsk" ;
+    fresh_A = mkA "färsk" ;
     warm_A = mkA "varm" ;
     italian_A = mkA "italiensk" ;
     expensive_A = mkA "dyr" ;
-    delicious_A = mkA "läcker" ;
+    delicious_A = mkA "läcker" ;
-    boring_A = mkA "tråkig" ;
+    boring_A = mkA "tråkig" ;
 }

gf-book/examples/chapter7/QueryFin.gf

@@ -6,7 +6,7 @@ concrete QueryFin of Query = {
     Odd   = pred "pariton" ;
     Prime = pred "alkuluku" ;
     Number i = i.s ;
-    Yes = "kyllä" ;
+    Yes = "kyllä" ;
     No = "ei" ;
   oper
     pred : Str -> Str -> Str = \f,x -> "onko" ++ x ++ f ;

gf-book/examples/chapter9/ResIta.gf

@@ -46,7 +46,7 @@ oper
     Avere =>
       mkVerb "avere" "ho" "hai" "ha" "abbiamo" "avete" "hanno" "avuto" Avere ;
     Essere =>
-      mkVerb "essere" "sono" "sei" "è" "siamo" "siete" "sono" "stato" Essere
+      mkVerb "essere" "sono" "sei" "è" "siamo" "siete" "sono" "stato" Essere
     } ;
 
   agrPart : Verb -> Agr -> ClitAgr -> Str = \v,a,c -> case v.aux of {

gf.cabal

@@ -1,19 +1,24 @@
 name: gf
-version: 3.11.0-git
+version: 3.12.0
 
 cabal-version: 1.22
-build-type: Custom
+build-type: Simple
 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
+maintainer: John J. Camilleri <john@digitalgrammars.com>
 homepage: https://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4, GHC==9.0.2, GHC==9.2.4, GHC==9.6.7
 
 data-dir: src
-extra-source-files: WebSetup.hs
+extra-source-files:
+  README.md
+  CHANGELOG.md
+  WebSetup.hs
+  doc/Logos/gf0.png
 data-files:
   www/*.html
   www/*.css
@@ -39,14 +44,6 @@ data-files:
   www/translator/*.css
   www/translator/*.js
 
-custom-setup
-  setup-depends:
-    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
   location: https://github.com/GrammaticalFramework/gf-core.git
@@ -63,38 +60,129 @@ flag network-uri
    description: Get Network.URI from the network-uri package
    default: True
 
-executable gf
+--flag new-comp
-  hs-source-dirs: src/programs, src/compiler
+--  Description: Make -new-comp the default
-  main-is: gf-main.hs
+--  Default:     True
-  default-language:    Haskell2010
+
-  build-depends: pgf2,
+flag c-runtime
-                 base >= 4.6 && <5,
+  Description: Include functionality from the C run-time library (which must be installed already)
-                 array,
+  Default: False
-                 containers,
+
-                 bytestring,
+library
-                 utf8-string,
+  default-language: Haskell2010
-                 random,
+  build-depends:
-                 pretty,
+    -- GHC 8.0.2 to GHC 8.10.4
-                 mtl,
+    array >= 0.5.1 && < 0.6,
-                 exceptions,
+    base >= 4.9.1 && < 4.22,
-                 ghc-prim,
+    bytestring >= 0.10.8 && < 0.12,
-                 filepath, directory>=1.2, time,
+    containers >= 0.5.7 && < 0.7,
-                 process, haskeline, parallel>=3, json
+    exceptions >= 0.8.3 && < 0.11,
-  ghc-options: -threaded
+    ghc-prim >= 0.5.0 && <= 0.10.0,
+    mtl >= 2.2.1 && <= 2.3.1,
+    pretty >= 1.1.3 && < 1.2,
+    random >= 1.1 && < 1.3,
+    utf8-string >= 1.0.1.1 && < 1.1
+
+  if impl(ghc<8.0)
+    build-depends:
+      -- We need this in order for ghc-7.10 to build
+      transformers-compat >= 0.6.3 && < 0.7,
+      fail >= 4.9.0 && < 4.10
+
+  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:
+    directory >= 1.3.0 && < 1.4,
+    filepath >= 1.4.1 && < 1.5,
+    haskeline >= 0.7.3 && < 0.9,
+    json >= 0.9.1 && <= 0.11,
+    parallel >= 3.2.1.1 && < 3.3,
+    process >= 1.4.3 && < 1.7,
+    time >= 1.6.0 && <= 1.12.2,
+    template-haskell >= 2.13.0.0 && < 2.21
+
+  hs-source-dirs: src/compiler
+  exposed-modules:
     GF
     GF.Support
     GF.Text.Pretty
     GF.Text.Lexing
     GF.Grammar.Canonical
 
-    GF.Main GF.Compiler GF.Interactive
+  other-modules:
+    GF.Main
+    GF.Compiler
+    GF.Interactive
 
-    GF.Compile GF.CompileInParallel GF.CompileOne  GF.Compile.GetGrammar
+    GF.Compile
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compile.GetGrammar
     GF.Grammar
 
-    GF.Data.Operations GF.Infra.Option GF.Infra.UseIO
+    GF.Data.Operations
+    GF.Infra.Option
+    GF.Infra.UseIO
 
     GF.Command.Abstract
     GF.Command.CommandInfo
@@ -109,9 +197,9 @@ executable gf
     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
@@ -119,14 +207,16 @@ executable gf
     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
@@ -193,35 +283,123 @@ executable gf
     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
 
-    -- not really part of GF but I have changed the original binary library
+  if flag(c-runtime)
-    -- and we have to keep the copy for now.
+    cpp-options: -DC_RUNTIME
-    Data.Binary
+
-    Data.Binary.Put
+  if flag(server)
-    Data.Binary.Get
+    build-depends:
-    Data.Binary.Builder
+      cgi >= 3001.3.0.2 && < 3001.6,
-    Data.Binary.IEEE754
+      httpd-shed >= 0.4.0 && < 0.5,
+      network>=2.3 && <3.2
+    if flag(network-uri)
+      build-depends:
+        network-uri >= 2.6.1.0 && < 2.7,
+        network>=2.6 && <3.2
+    else
+      build-depends:
+        network >= 2.5 && <3.2
+
+    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
 
   if os(windows)
     build-depends:
       Win32 >= 2.3.1.1 && < 2.7
   else
     build-depends:
-      terminfo >=0.4.0 && < 0.5,
+      terminfo >=0.4.0 && < 0.5
-      unix >= 2.7.2 && < 2.8
+
+    if impl(ghc >= 9.6.6)
+      build-depends: unix >= 2.8 && < 2.9
+
+    else
+      build-depends: unix >= 2.7.2 && < 2.8
+
+
+  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 >= 4.9.1 && < 4.22
+  ghc-options: -threaded
+--ghc-options: -fwarn-unused-imports
+
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts -with-rtsopts=-I5
+    if impl(ghc<7.8)
+      ghc-options: -with-rtsopts=-K64M
+
+  -- ghc-prof-options: -auto-all
+
+  if impl(ghc>=8.2)
+    ghc-options: -fhide-source-paths
+
+-- executable pgf-shell
+-- --if !flag(c-runtime)
+--   buildable: False
+--   main-is: pgf-shell.hs
+--   hs-source-dirs: src/runtime/haskell-bind/examples
+--   build-depends:
+--     gf,
+--     base,
+--     containers,
+--     mtl,
+--     lifted-base
+--   default-language: Haskell2010
+--   if impl(ghc>=7.0)
+--     ghc-options: -rtsopts
 
 test-suite gf-tests
   type: exitcode-stdio-1.0
   main-is: run.hs
   hs-source-dirs: testsuite
   build-depends:
-    base >= 4.9.1 && < 4.15,
+    base >= 4.9.1 && < 4.22,
     Cabal >= 1.8,
     directory >= 1.3.0 && < 1.4,
     filepath >= 1.4.1 && < 1.5,

index.html

@@ -8,7 +8,7 @@
 
   <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
   <link rel="stylesheet" href="https://stackpath.bootstrapcdn.com/bootstrap/4.1.3/css/bootstrap.min.css" integrity="sha384-MCw98/SFnGE8fJT3GXwEOngsV7Zt27NXFoaoApmYm81iuXoPkFOJwJ8ERdknLPMO" crossorigin="anonymous">
-  <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.4.2/css/all.css" integrity="sha384-/rXc/GQVaYpyDdyxK+ecHPVYJSN9bmVFBvjA/9eOB+pb3F2w2N6fc5qB9Ew5yIns" crossorigin="anonymous">
+  <link rel="stylesheet" href="https://use.fontawesome.com/releases/v5.15.4/css/all.css" crossorigin="anonymous">
 
   <link rel="alternate" href="https://github.com/GrammaticalFramework/gf-core/" title="GF GitHub repository">
 </head>
@@ -57,6 +57,7 @@
       <li><a href="doc/gf-shell-reference.html">Shell Reference</a></li>
       <li><a href="http://www.molto-project.eu/sites/default/files/MOLTO_D2.3.pdf">Best Practices</a> <small>[PDF]</small></li>
       <li><a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Scaling Up (Computational Linguistics 2020)</a></li>
+      <li><a href="https://inariksit.github.io/blog/">GF blog</a></li>
     </ul>
 
     <a href="lib/doc/synopsis/index.html" class="btn btn-primary ml-3">
@@ -85,10 +86,22 @@
   <div class="col-sm-6 col-md-3 mb-4">
     <h3>Contribute</h3>
     <ul class="mb-2">
-      <li><a href="http://groups.google.com/group/gf-dev">Mailing List</a></li>
+      <li>
+        <a href="https://discord.gg/EvfUsjzmaz">
+          <i class="fab fa-discord"></i>
+          Discord
+        </a>
+      </li>
+      <li>
+        <a href="https://stackoverflow.com/questions/tagged/gf">
+          <i class="fab fa-stack-overflow"></i>
+          Stack Overflow
+        </a>
+      </li>
+      <li><a href="https://groups.google.com/group/gf-dev">Mailing List</a></li>
       <li><a href="https://github.com/GrammaticalFramework/gf-core/issues">Issue Tracker</a></li>
+      <li><a href="//school.grammaticalframework.org/">Summer School</a></li>
       <li><a href="doc/gf-people.html">Authors</a></li>
-      <li><a href="//school.grammaticalframework.org/2020/">Summer School</a></li>
     </ul>
     <a href="https://github.com/GrammaticalFramework/" class="btn btn-primary ml-3">
       <i class="fab fa-github mr-1"></i>
@@ -154,7 +167,7 @@ least one, it may help you to get a first idea of what GF is.
 <div class="row">
 
   <div class="col-md-6">
-    <h2>Applications & Availability</h2>
+    <h2>Applications & availability</h2>
     <p>
     GF can be used for building
     <a href="//cloud.grammaticalframework.org/translator/">translation systems</a>,
@@ -214,64 +227,50 @@ 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 Libera network, where you are welcome to look for help with small questions or just start a general discussion.
+    We run the <a href="https://discord.gg/EvfUsjzmaz">GF server on Discord</a>, 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>.
+    For bug reports and feature requests, please create an issue in the
+    <a href="https://github.com/GrammaticalFramework/gf-core/issues">GF Core</a> or
+    <a href="https://github.com/GrammaticalFramework/gf-rgl/issues">RGL</a> repository.
+
+    For programming questions, consider asking them on <a href="https://stackoverflow.com/questions/tagged/gf">Stack Overflow with the <code>gf</code> tag</a>.
+    If you have a more general question to the community, we recommend you ask it on the <a href="http://groups.google.com/group/gf-dev">mailing list</a>.
     </p>
 
   </div>
 
   <div class="col-md-6">
     <h2>News</h2>
-    <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">2025-08-08</dt>
+      <dd class="col-sm-9">
+        <strong>GF 3.12 released.</strong>
+        <a href="download/release-3.12.html">Release notes</a>
+      </dd>
+      <dt class="col-sm-3 text-center text-nowrap">2025-01-18</dt>
+      <dd class="col-sm-9">
+        <a href="//school.grammaticalframework.org/2025/">9th GF Summer School</a>, in Gothenburg, Sweden, 18 &ndash; 29 August 2025.
+      </dd>
+      <dt class="col-sm-3 text-center text-nowrap">2023-01-24</dt>
+      <dd class="col-sm-9">
+        <a href="//school.grammaticalframework.org/2023/">8th GF Summer School</a>, in Tampere, Finland, 14 &ndash; 25 August 2023.
+      </dd>
+      <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>
       <dt class="col-sm-3 text-center text-nowrap">2021-05-05</dt>
       <dd class="col-sm-9">
         <a href="https://cloud.grammaticalframework.org/wordnet/">GF WordNet</a> now supports languages for which there are no other WordNets. New additions: Afrikaans, German, Korean, Maltese, Polish, Somali, Swahili.
       </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2021-03-01</dt>
-      <dd class="col-sm-9">
-        <a href="//school.grammaticalframework.org/2020/">Seventh GF Summer School</a>, in Singapore and online, 26 July &ndash; 6 August 2021.
-      </dd>
       <dt class="col-sm-3 text-center text-nowrap">2020-09-29</dt>
       <dd class="col-sm-9">
         <a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Abstract Syntax as Interlingua</a>: Scaling Up the Grammatical Framework from Controlled Languages to Robust Pipelines. A paper in Computational Linguistics (2020) summarizing much of the development in GF in the past ten years.
       </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2018-12-03</dt>
-      <dd class="col-sm-9">
-        <a href="//school.grammaticalframework.org/2018/">Sixth GF Summer School</a> in Stellenbosch (South Africa), 3–14 December 2018
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2018-12-02</dt>
-      <dd class="col-sm-9">
-        <strong>GF 3.10 released.</strong>
-        <a href="download/release-3.10.html">Release notes</a>
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2018-07-25</dt>
-      <dd class="col-sm-9">
-        The GF repository has been split in two:
-        <a href="https://github.com/GrammaticalFramework/gf-core">gf-core</a> and
-        <a href="https://github.com/GrammaticalFramework/gf-rgl">gf-rgl</a>.
-        The original <a href="https://github.com/GrammaticalFramework/GF">GF</a> repository is now archived.
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-08-11</dt>
-      <dd class="col-sm-9">
-        <strong>GF 3.9 released.</strong>
-        <a href="download/release-3.9.html">Release notes</a>
-      </dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-06-29</dt>
-      <dd class="col-sm-9">
-        GF is moving to <a href="https://github.com/GrammaticalFramework/GF/">GitHub</a>.</dd>
-      <dt class="col-sm-3 text-center text-nowrap">2017-03-13</dt>
-      <dd class="col-sm-9">
-        <a href="//school.grammaticalframework.org/2017/">GF Summer School</a> in Riga (Latvia), 14-25 August 2017
-      </dd>
     </dl>
 
     <h2>Projects</h2>
@@ -341,7 +340,7 @@ least one, it may help you to get a first idea of what GF is.
     Libraries are at the heart of modern software engineering. In natural language
     applications, libraries are a way to cope with thousands of details involved in
     syntax, lexicon, and inflection. The
-    <a href="lib/doc/synopsis/index.html">GF resource grammar library</a> has
+    <a href="lib/doc/synopsis/index.html">GF resource grammar library</a> (RGL) has
     support for an increasing number of languages, currently including
     Afrikaans,
     Amharic (partial),

nix/expose-all.patch

@@ -0,0 +1,12 @@
+diff --git a/gf.cabal b/gf.cabal
+index 0076e7638..8d3fe4b49 100644
+--- a/gf.cabal
++++ b/gf.cabal
+@@ -168,7 +168,6 @@ Library
+     GF.Text.Lexing
+     GF.Grammar.Canonical
+
+-  other-modules:
+     GF.Main
+     GF.Compiler
+     GF.Interactive

nix/revert-new-cabal-madness.patch

@@ -0,0 +1,193 @@
+commit 45e5473fcd5707af93646d9a116867a4d4e3e9c9
+Author: Andreas Källberg <anka.213@gmail.com>
+Date:   Mon Oct 10 14:57:12 2022 +0200
+
+    Revert "workaround for the Nix madness"
+    
+    This reverts commit 1294269cd60f3db7b056135104615625baeb528c.
+    
+    There are easier workarounds, like using
+    
+      cabal v1-build
+    
+    etc. instead of just `cabal build`
+    
+    These changes also broke a whole bunch of other stuff
+
+diff --git a/README.md b/README.md
+index ba35795a4..79e6ab68f 100644
+--- a/README.md
++++ b/README.md
+@@ -38,21 +38,6 @@ or:
+ ```
+ stack install
+ ```
+-Note that if you are unlucky to have Cabal 3.0 or later, then it uses
+-the so-called Nix style commands. Using those for GF development is
+-a pain. Every time when you change something in the source code, Cabal
+-will generate a new folder for GF to look for the GF libraries and
+-the GF cloud. Either reinstall everything with every change in the
+-compiler, or be sane and stop using cabal-install. Instead you can do:
+-```
+-runghc Setup.hs configure
+-runghc Setup.hs build
+-sudo runghc Setup.hs install
+-```
+-The script will install the GF dependencies globally. The only solution
+-to the Nix madness that I found is radical:
+-
+-  "No person, no problem" (Нет человека – нет проблемы).
+ 
+ For more information, including links to precompiled binaries, see the [download page](https://www.grammaticalframework.org/download/index.html).
+ 
+diff --git a/Setup.hs b/Setup.hs
+index 58dc3e0c6..f8309cc00 100644
+--- a/Setup.hs
++++ b/Setup.hs
+@@ -4,68 +4,42 @@ import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs
+ import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..),SDistFlags(..))
+ import Distribution.PackageDescription(PackageDescription(..),emptyHookedBuildInfo)
+ import Distribution.Simple.BuildPaths(exeExtension)
+-import System.Directory
+ import System.FilePath((</>),(<.>))
+-import System.Process
+-import Control.Monad(forM_,unless)
+-import Control.Exception(bracket_)
+-import Data.Char(isSpace)
+ 
+ import WebSetup
+ 
++-- | Notice about RGL not built anymore
++noRGLmsg :: IO ()
++noRGLmsg = putStrLn "Notice: the RGL is not built as part of GF anymore. See https://github.com/GrammaticalFramework/gf-rgl"
++
+ main :: IO ()
+ main = defaultMainWithHooks simpleUserHooks
+-  { preConf   = gfPreConf
+-  , preBuild  = gfPreBuild
++  { preBuild  = gfPreBuild
+   , postBuild = gfPostBuild
+   , preInst   = gfPreInst
+   , postInst  = gfPostInst
+   , postCopy  = gfPostCopy
+   }
+   where
+-    gfPreConf args flags = do
+-      pkgs <- fmap (map (dropWhile isSpace) . tail . lines)
+-                   (readProcess "ghc-pkg" ["list"] "")
+-      forM_ dependencies $ \pkg -> do
+-        let name = takeWhile (/='/') (drop 36 pkg)
+-        unless (name `elem` pkgs) $ do
+-          let fname = name <.> ".tar.gz"
+-          callProcess "wget" [pkg,"-O",fname]
+-          callProcess "tar"  ["-xzf",fname]
+-          removeFile fname
+-          bracket_ (setCurrentDirectory name) (setCurrentDirectory ".." >> removeDirectoryRecursive name) $ do
+-            exists <- doesFileExist "Setup.hs"
+-            unless exists $ do
+-              writeFile "Setup.hs" (unlines [
+-                  "import Distribution.Simple",
+-                  "main = defaultMain"
+-                ])
+-            let to_descr = reverse .
+-                           (++) (reverse ".cabal") . 
+-                           drop 1 . 
+-                           dropWhile (/='-') . 
+-                           reverse
+-            callProcess "wget"   [to_descr pkg, "-O", to_descr name]
+-            callProcess "runghc" ["Setup.hs","configure"]
+-            callProcess "runghc" ["Setup.hs","build"]
+-            callProcess "sudo" ["runghc","Setup.hs","install"]
+-          
+-      preConf simpleUserHooks args flags
+-
+-    gfPreBuild args = gfPre args . buildDistPref
+-    gfPreInst  args = gfPre args . installDistPref
++    gfPreBuild args  = gfPre args . buildDistPref
++    gfPreInst args = gfPre args . installDistPref
+ 
+     gfPre args distFlag = do
+       return emptyHookedBuildInfo
+ 
+     gfPostBuild args flags pkg lbi = do
++      -- noRGLmsg
+       let gf = default_gf lbi
+       buildWeb gf flags (pkg,lbi)
+ 
+     gfPostInst args flags pkg lbi = do
++      -- noRGLmsg
++      saveInstallPath args flags (pkg,lbi)
+       installWeb (pkg,lbi)
+ 
+     gfPostCopy args flags  pkg lbi = do
++      -- noRGLmsg
++      saveCopyPath args flags (pkg,lbi)
+       copyWeb flags (pkg,lbi)
+ 
+     -- `cabal sdist` will not make a proper dist archive, for that see `make sdist`
+@@ -73,16 +47,27 @@ main = defaultMainWithHooks simpleUserHooks
+     gfSDist pkg lbi hooks flags = do
+       return ()
+ 
+-dependencies = [
+-  "https://hackage.haskell.org/package/utf8-string-1.0.2/utf8-string-1.0.2.tar.gz",
+-  "https://hackage.haskell.org/package/json-0.10/json-0.10.tar.gz",
+-  "https://hackage.haskell.org/package/network-bsd-2.8.1.0/network-bsd-2.8.1.0.tar.gz",
+-  "https://hackage.haskell.org/package/httpd-shed-0.4.1.1/httpd-shed-0.4.1.1.tar.gz",
+-  "https://hackage.haskell.org/package/exceptions-0.10.5/exceptions-0.10.5.tar.gz",
+-  "https://hackage.haskell.org/package/stringsearch-0.3.6.6/stringsearch-0.3.6.6.tar.gz",
+-  "https://hackage.haskell.org/package/multipart-0.2.1/multipart-0.2.1.tar.gz",
+-  "https://hackage.haskell.org/package/cgi-3001.5.0.0/cgi-3001.5.0.0.tar.gz"
+-  ]
++saveInstallPath :: [String] -> InstallFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
++saveInstallPath args flags bi = do
++  let
++    dest = NoCopyDest
++    dir = datadir (uncurry absoluteInstallDirs bi dest)
++  writeFile dataDirFile dir
++
++saveCopyPath :: [String] -> CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
++saveCopyPath args flags bi = do
++  let
++    dest = case copyDest flags of
++      NoFlag -> NoCopyDest
++      Flag d -> d
++    dir = datadir (uncurry absoluteInstallDirs bi dest)
++  writeFile dataDirFile dir
++
++-- | Name of file where installation's data directory is recording
++-- This is a last-resort way in which the seprate RGL build script
++-- can determine where to put the compiled RGL files
++dataDirFile :: String
++dataDirFile = "DATA_DIR"
+ 
+ -- | Get path to locally-built gf
+ default_gf :: LocalBuildInfo -> FilePath
+diff --git a/gf.cabal b/gf.cabal
+index a055b86be..d00a5b935 100644
+--- a/gf.cabal
++++ b/gf.cabal
+@@ -2,7 +2,7 @@ name: gf
+ version: 3.11.0-git
+ 
+ cabal-version: 1.22
+-build-type: Simple
++build-type: Custom
+ license: OtherLicense
+ license-file: LICENSE
+ category: Natural Language Processing, Compiler
+@@ -44,6 +44,14 @@ data-files:
+   www/translator/*.css
+   www/translator/*.js
+ 
++custom-setup
++  setup-depends:
++    base >= 4.9.1 && < 4.16,
++    Cabal >= 1.22.0.0,
++    directory >= 1.3.0 && < 1.4,
++    filepath >= 1.4.1 && < 1.5,
++    process >= 1.0.1.1 && < 1.7
++
+ source-repository head
+   type: git
+   location: https://github.com/GrammaticalFramework/gf-core.git

src/compiler/GF/Command/Abstract.hs

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

src/compiler/GF/Command/CommandInfo.hs

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

src/compiler/GF/Command/Commands.hs

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

src/compiler/GF/Command/Commands2.hs

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

src/compiler/GF/Command/CommonCommands.hs

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

src/compiler/GF/Command/Importing.hs

@@ -1,7 +1,7 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
-import PGF2
+import PGF
-import PGF2.Internal(unionPGF)
+import PGF.Internal(optimizePGF,unionPGF,msgUnionPGF)
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)
@@ -17,16 +17,14 @@ import GF.Data.ErrM
 
 import System.FilePath
 import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Control.Monad(foldM)
 
 -- import a grammar in an environment where it extends an existing grammar
-importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
+importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
-importGrammar pgf0 _    []    = return pgf0
+importGrammar pgf0 _ [] = return pgf0
 importGrammar pgf0 opts files =
   case takeExtensions (last files) of
-    ".cf"   -> fmap Just $ importCF opts files getBNFCRules bnfc2cf
+    ".cf"   -> importCF opts files getBNFCRules bnfc2cf
-    ".ebnf" -> fmap Just $ importCF opts files getEBNFRules ebnf2cf
+    ".ebnf" -> importCF opts files getEBNFRules ebnf2cf
     ".gfm"  -> do
       ascss <- mapM readMulti files
       let cs = concatMap snd ascss
@@ -38,15 +36,14 @@ importGrammar pgf0 opts files =
         Bad msg -> do putStrLn ('\n':'\n':msg)
                       return pgf0
     ".pgf" -> do
-      mapM readPGF files >>= foldM ioUnionPGF pgf0
+      pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
+      ioUnionPGF pgf0 pgf2
     ext -> die $ "Unknown filename extension: " ++ show ext
 
-ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)
+ioUnionPGF :: PGF -> PGF -> IO PGF
-ioUnionPGF Nothing    two = return (Just two)
+ioUnionPGF one two = case msgUnionPGF one two of
-ioUnionPGF (Just one) two =
+  (pgf, Just msg) -> putStrLn msg >> return pgf
-  case unionPGF one two of
+  (pgf,_)         -> return pgf
-    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)
@@ -59,6 +56,7 @@ importCF opts files get convert = impCF
       startCat <- case rules of
                     (Rule cat _ _ : _) -> return cat
                     _                  -> fail "empty CFG"
-      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
+      let pgf = cf2pgf (last files) (mkCFG startCat Set.empty rules)
-      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
+      probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf
-      return pgf
+      return $ setProbabilities probs 
+             $ if flag optOptimizePGF opts then optimizePGF pgf else 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,8 +56,17 @@ interpretPipe env cs = do
 -- | macro definition applications: replace ?i by (exps !! i)
 appCommand :: CommandArguments -> Command -> Command
 appCommand args c@(Command i os arg) = case arg of
-  AExpr e -> Command i os (AExpr (exprSubstitute e (toExprs args)))
+  AExpr e -> Command i os (AExpr (app e))
   _       -> c
+ where
+  xs = toExprs args
+
+  app e = case e of
+    EAbs b x e -> EAbs b x (app e)
+    EApp e1 e2 -> EApp (app e1) (app e2)
+    ELit l     -> ELit l
+    EMeta i    -> xs !! i
+    EFun x     -> EFun x
 
 -- | return the trees to be sent in pipe, and the output possibly printed
 --interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
@@ -104,4 +113,4 @@ getCommandTrees env needsTypeCheck a args =
     ATerm t -> return (Term t)
     ANoArg  -> return args  -- use piped
   where
-    one e = return (Exprs [(e,0)]) -- ignore piped
+    one e = return (Exprs [e]) -- ignore piped

src/compiler/GF/Command/Parse.hs

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

src/compiler/GF/Command/TreeOperations.hs

@@ -1,29 +1,34 @@
 module GF.Command.TreeOperations (
   treeOp,
   allTreeOps,
+  treeChunks
   ) where
 
-import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unMeta,exprSize,exprFunctions)
+import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
+import PGF.Data(Expr(EApp,EFun))
+import PGF.TypeCheck(inferExpr)
 import Data.List
 
 type TreeOp = [Expr] -> [Expr]
 
-treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
+treeOp :: PGF -> String -> Maybe (Either TreeOp (CId -> TreeOp))
 treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
 
-allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
+allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))]
 allTreeOps pgf = [
    ("compute",("compute by using semantic definitions (def)",
       Left  $ map (compute pgf))),
+   ("transfer",("apply this transfer function to all maximal subtrees of suitable type",
+      Right $ \f -> map (transfer pgf f))), -- HL 12/24, modified from gf-3.3
    ("largest",("sort trees from largest to smallest, in number of nodes",
       Left  $ largest)),
-   ("nub",("remove duplicate trees",
+   ("nub\t",("remove duplicate trees",
       Left  $ nub)),
    ("smallest",("sort trees from smallest to largest, in number of nodes",
       Left  $ smallest)),
    ("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest",
       Left  $ concatMap subtrees)),
-   ("funs",("return all fun functions appearing in the tree, with duplications",
+   ("funs\t",("return all fun functions appearing in the tree, with duplications",
       Left  $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e]))
   ]
 
@@ -33,7 +38,32 @@ 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
   _ -> []  -- don't go under abstractions
+
+-- Apply transfer function f:C -> D to all maximal subtrees s:C of tree e and replace
+-- these s by the values of f(s). This modifies the 'simple-minded transfer' of gf-3.3.
+-- If applied to strict subtrees s of e, better use with f:C -> C only.  HL 12/2024
+
+transfer :: PGF -> CId -> Expr -> Expr
+transfer pgf f e = case inferExpr pgf (appf e) of
+     Left _err -> case e of
+                    EApp g a -> EApp (transfer pgf f g) (transfer pgf f a)
+                    _ -> e
+     Right _ty -> case (compute pgf (appf e)) of
+                    v | v /= (appf e) -> v
+                    _ -> e          -- default case of f, or f has no computation rule
+ where
+  appf = EApp (EFun f)

src/compiler/GF/Compile.hs

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

src/compiler/GF/Compile/CFGtoPGF.hs

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

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

@@ -172,11 +172,11 @@ value env t0 =
     ImplArg t -> (VImplArg.) # value env t
     Table p res -> liftM2 VTblType # value env p <# value env res
     RecType rs -> do lovs <- mapPairsM (value env) rs
-                     return $ \vs->VRecType $ mapSnd ($vs) lovs
+                     return $ \vs->VRecType $ mapSnd ($ vs) lovs
     t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
     FV ts   -> ((vfv .) # sequence) # mapM (value env) ts
     R as    -> do lovs <- mapPairsM (value env.snd) as
-                  return $ \ vs->VRec $ mapSnd ($vs) lovs
+                  return $ \ vs->VRec $ mapSnd ($ vs) lovs
     T i cs  -> valueTable env i cs
     V ty ts -> do pvs <- paramValues env ty
                   ((VV ty pvs .) . sequence) # mapM (value env) ts
@@ -376,10 +376,10 @@ valueTable env i cs =
   where
     dynamic cs' ty _ = cases cs' # value env ty
 
-    cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs))
+    cases cs' vty vs = err keep ($ vs) (convertv cs' (vty vs))
       where
         keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $
-                   VT wild (vty vs) (mapSnd ($vs) cs')
+                   VT wild (vty vs) (mapSnd ($ vs) cs')
 
     wild = case i of TWild _ -> True; _ -> False
 
@@ -392,7 +392,7 @@ valueTable env i cs =
     convert' cs' ((pty,vs),pvs) =
       do sts  <- mapM (matchPattern cs') vs
          return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
-                                           (mapFst ($vs) sts)
+                                           (mapFst ($ vs) sts)
 
     valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
                          pvs <- linPattVars p'
@@ -430,19 +430,19 @@ apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
 apply' env t [] = value env t
 apply' env t vs =
   case t of
-    QC x                   -> return $ \ svs -> VCApp x (map ($svs) vs)
+    QC x                   -> return $ \ svs -> VCApp x (map ($ svs) vs)
 {-
     Q x@(m,f) | m==cPredef -> return $
                               let constr = --trace ("predef "++show x) .
                                            VApp x
                               in \ svs -> maybe constr id (Map.lookup f predefs)
-                                          $ map ($svs) vs
+                                          $ map ($ svs) vs
               | otherwise  -> do r <- resource env x
-                                 return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
+                                 return $ \ svs -> vapply (gloc env) r (map ($ svs) vs)
 -}
     App t1 t2              -> apply' env t1 . (:vs) =<< value env t2
     _                      -> do fv <- value env t
-                                 return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
+                                 return $ \ svs -> vapply (gloc env) (fv svs) (map ($ svs) vs)
 
 vapply :: GLocation -> Value -> [Value] -> Value
 vapply loc v [] = v

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

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

src/compiler/GF/Compile/ExampleBased.hs

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

src/compiler/GF/Compile/Export.hs

@@ -1,10 +1,14 @@
 module GF.Compile.Export where
 
-import PGF2
+import PGF
+import PGF.Internal(ppPGF)
 import GF.Compile.PGFtoHaskell
 --import GF.Compile.PGFtoAbstract
 import GF.Compile.PGFtoJava
+import GF.Compile.PGFtoProlog
+import GF.Compile.PGFtoJS
 import GF.Compile.PGFtoJSON
+import GF.Compile.PGFtoPython
 import GF.Infra.Option
 --import GF.Speech.CFG
 import GF.Speech.PGFToCFG
@@ -18,7 +22,6 @@ import GF.Speech.SLF
 import GF.Speech.PrRegExp
 
 import Data.Maybe
-import qualified Data.Map as Map
 import System.FilePath
 import GF.Text.Pretty
 
@@ -32,12 +35,15 @@ exportPGF :: Options
           -> [(FilePath,String)] -- ^ List of recommended file names and contents.
 exportPGF opts fmt pgf = 
     case fmt of
-      FmtPGFPretty    -> multi "txt" (showPGF)
+      FmtPGFPretty    -> multi "txt" (render . ppPGF)
       FmtCanonicalGF  -> [] -- canon "gf" (render80 . abstract2canonical)
       FmtCanonicalJson-> []
+      FmtJavaScript   -> multi "js"  pgf2js
       FmtJSON         -> multi "json"  pgf2json
+      FmtPython       -> multi "py"  pgf2python
       FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
       FmtJava         -> multi "java" (grammar2java opts name)
+      FmtProlog       -> multi "pl"  grammar2prolog
       FmtBNF          -> single "bnf"   bnfPrinter
       FmtEBNF         -> single "ebnf"  (ebnfPrinter opts)
       FmtSRGS_XML     -> single "grxml" (srgsXmlPrinter opts)
@@ -51,13 +57,20 @@ exportPGF opts fmt pgf =
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
  where
-   name = fromMaybe (abstractName pgf) (flag optName opts)
+   name = fromMaybe (showCId (abstractName pgf)) (flag optName opts)
 
    multi :: String -> (PGF -> String) -> [(FilePath,String)]
    multi ext pr = [(name <.> ext, pr pgf)]
 
 -- canon ext pr = [("canonical"</>name<.>ext,pr pgf)]
 
-   single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
+   single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
-   single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages pgf)]
+   single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf]
 
+
+-- | Get the name of the concrete syntax to generate output from.
+-- FIXME: there should be an option to change this.
+outputConcr :: PGF -> CId
+outputConcr pgf = case languages pgf of
+                    []     -> error "No concrete syntax."
+                    cnc:_  -> cnc

src/compiler/GF/Compile/GenerateBC.hs

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

src/compiler/GF/Compile/GeneratePMCFG.hs

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

src/compiler/GF/Compile/GetGrammar.hs

@@ -42,21 +42,29 @@ getSourceModule opts file0 =
      raw <- liftIO $ keepTemp tmp
    --ePutStrLn $ "1 "++file0
      (optCoding,parsed) <- parseSource opts pModDef raw
+     let indentLines = unlines . map ("   "++) . lines
      case parsed of
        Left (Pn l c,msg) -> do file <- liftIO $ writeTemp tmp
                                cwd <- getCurrentDirectory
                                let location = makeRelative cwd file++":"++show l++":"++show c
-                               raise (location++":\n   "++msg)
+                               raise (location++":\n" ++ indentLines msg)
        Right (i,mi0) ->
          do liftIO $ removeTemp tmp
             let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
-            case renameEncoding `fmap` flag optEncoding (mflags mi0) of
+                optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
-              Just coding' -> 
+            case (optCoding,optCoding') of
-                when (coding/=coding') $
+              {-
+              (Nothing,Nothing) ->
+                  unless (BS.all isAscii raw) $
+                    ePutStrLn $ file0++":\n    Warning: default encoding has changed from Latin-1 to UTF-8"
+              -}
+              (_,Just coding') -> 
+                  when (coding/=coding') $
                   raise $ "Encoding mismatch: "++coding++" /= "++coding'
                 where coding = maybe defaultEncoding renameEncoding optCoding
               _ -> return ()
-            return (i,mi)
+          --liftIO $ transcodeModule' (i,mi) -- old lexer
+            return (i,mi) -- new lexer
 
 getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
 getBNFCRules opts fpath = do

src/compiler/GF/Compile/GrammarToCanonical.hs

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

src/compiler/GF/Compile/OptimizePGF.hs

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

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -16,14 +16,13 @@
 
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
-import PGF2
+import PGF(showCId)
-import PGF2.Internal
+import PGF.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
@@ -52,7 +51,7 @@ grammar2haskell opts name gr = foldr (++++) [] $
           derivingClause
                  | dataExt = "deriving (Show,Data)"
                  | otherwise = "deriving Show"
-          extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
+          extraImports | gadt = ["import Control.Monad.Identity", "import Control.Monad", "import Data.Monoid"]
                        | dataExt = ["import Data.Data"]
                        | otherwise = []
           pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
@@ -259,7 +258,7 @@ fInstance gId lexical m (cat,rules) =
     then "    " ++ gId cat ++ " (fgs t) where\n     fgs t = case unApp t of"
     else "    case unApp t of") ++++
   unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
-  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
+  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "(showCId i)" else "") ++++
   "      _ -> error (\"no" +++ cat ++ " \" ++ show t)"
    where
     isList = isListCat (cat,rules)
@@ -281,21 +280,18 @@ fInstance gId lexical m (cat,rules) =
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
 hSkeleton gr =
-  (abstractName gr,
+  (showCId (absname gr),
    let fs =
-         [(c, [(f, cs) | (f, cs,_) <- fs]) | 
+         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
-                                        fs@((_, _,c):_) <- fns]
+                                        fs@((_, (_,c)):_) <- fns]
-   in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
+   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
-   cts = categories gr
+   cts = Map.keys (cats (abstract gr))
-   fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
+   fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
-   valtyps (_,_,x) (_,_,y) = compare x y
+   valtyps (_, (_,x)) (_, (_,y)) = compare x y
-   valtypg (_,_,x) (_,_,y) = x == y
+   valtypg (_, (_,x)) (_, (_,y)) = x == y
-   jty f = case functionType gr f of
+   jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
-             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

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

src/compiler/GF/Compile/PGFtoJSON.hs

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

src/compiler/GF/Compile/PGFtoJava.hs

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

src/compiler/GF/Compile/PGFtoProlog.hs

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

src/compiler/GF/Compile/PGFtoPython.hs

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

src/compiler/GF/Compile/ToAPI.hs

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

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

@@ -644,7 +644,7 @@ data TcResult a
 newtype TcM a = TcM {unTcM :: MetaStore -> [Message] -> TcResult a}
 
 instance Monad TcM where
-  return x = TcM (\ms msgs -> TcOk x ms msgs)
+  return = pure
   f >>= g  = TcM (\ms msgs -> case unTcM f ms msgs of
                                 TcOk x ms msgs -> unTcM (g x) ms msgs
                                 TcFail    msgs -> TcFail msgs)
@@ -659,7 +659,7 @@ instance Fail.MonadFail TcM where
 
 
 instance Applicative TcM where
-  pure = return
+  pure x = TcM (\ms msgs -> TcOk x ms msgs)
   (<*>) = ap
 
 instance Functor TcM where

src/compiler/GF/CompileInParallel.hs

@@ -1,6 +1,6 @@
 -- | Parallel grammar compilation
 module GF.CompileInParallel(parallelBatchCompile) where
-import Prelude hiding (catch,(<>))
+import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import Control.Monad(join,ap,when,unless)
 import Control.Applicative
 import GF.Infra.Concurrency
@@ -36,8 +36,11 @@ import qualified Control.Monad.Fail as Fail
 parallelBatchCompile jobs opts rootfiles0 =
   do setJobs jobs
      rootfiles <- mapM canonical rootfiles0
-     lib_dir  <- canonical =<< getLibraryDirectory opts
+     lib_dirs1 <- getLibraryDirectory opts
-     filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
+     lib_dirs2 <- mapM canonical lib_dirs1
+     let lib_dir = head lib_dirs2
+     when (length lib_dirs2 >1) $ ePutStrLn ("GF_LIB_PATH defines more than one directory; using the first, " ++ show lib_dir)
+     filepaths <- mapM (getPathFromFile [lib_dir] opts) rootfiles
      let groups = groupFiles lib_dir filepaths
          n = length groups
      when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"
@@ -58,10 +61,10 @@ parallelBatchCompile jobs opts rootfiles0 =
 
         usesPresent (_,paths) = take 1 libs==["present"]
           where
-            libs = [p|path<-paths,
+            libs = [p | path<-paths,
-                      let (d,p0) = splitAt n path
+                        let (d,p0) = splitAt n path
-                          p = dropSlash p0,
+                            p = dropSlash p0,
-                      d==lib_dir,p `elem` all_modes]
+                      d==lib_dir, p `elem` all_modes]
             n = length lib_dir
 
         all_modes = ["alltenses","present"]
@@ -172,7 +175,7 @@ batchCompile1 lib_dir (opts,filepaths) =
                    " from being compiled."
        else return (maximum ts,(cnc,gr))
 
-splitEither es = ([x|Left x<-es],[y|Right y<-es])
+splitEither es = ([x | Left x<-es], [y | Right y<-es])
 
 canonical path = liftIO $ D.canonicalizePath path `catch` const (return path)
 
@@ -236,11 +239,11 @@ instance Functor m => Functor (CollectOutput m) where
    fmap f (CO m) = CO (fmap (fmap f) m)
 
 instance (Functor m,Monad m) => Applicative (CollectOutput m) where
-  pure = return
+  pure x = CO (return (return (),x))
   (<*>) = ap
 
 instance Monad m => Monad (CollectOutput m) where
-  return x = CO (return (return (),x))
+  return     = pure
   CO m >>= f = CO $ do (o1,x) <- m
                        let CO m2 = f x
                        (o2,y) <- m2

src/compiler/GF/Compiler.hs

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

src/compiler/GF/Data/BacktrackM.hs

@@ -64,11 +64,11 @@ finalStates :: BacktrackM s () -> s -> [s]
 finalStates bm = map fst . runBM bm
 
 instance Applicative (BacktrackM s) where
-    pure = return
+    pure a = BM (\c s b -> c a s b)
     (<*>) = ap
 
 instance Monad (BacktrackM s) where
-    return a   = BM (\c s b -> c a s b)
+    return     = pure
     BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
         where unBM (BM m) = m
 

src/compiler/GF/Data/ErrM.hs

@@ -34,7 +34,7 @@ fromErr :: a -> Err a -> a
 fromErr a = err (const a) id
 
 instance Monad Err where
-  return      = Ok
+  return      = pure
   Ok a  >>= f = f a
   Bad s >>= f = Bad s
 
@@ -54,7 +54,7 @@ instance Functor Err where
   fmap f (Bad s) = Bad s
 
 instance Applicative Err where
-  pure = return
+  pure = Ok
   (<*>) = ap
 
 -- | added by KJ

src/compiler/GF/Grammar/BNFC.hs

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

src/compiler/GF/Grammar/Binary.hs

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

src/compiler/GF/Grammar/CFG.hs

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

src/compiler/GF/Grammar/EBNF.hs

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

src/compiler/GF/Grammar/Grammar.hs

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
+        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence
         ) where
 
 import GF.Infra.Ident
@@ -73,12 +73,12 @@ import GF.Infra.Location
 
 import GF.Data.Operations
 
-import PGF2(BindType(..))
+import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
-import PGF2.Internal(FId, FunId, SeqId, LIndex, Symbol)
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import GF.Text.Pretty
 
 
@@ -100,7 +100,7 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Array SeqId [Symbol]),
+    mseqs   :: Maybe (Array SeqId Sequence),
     jments  :: Map.Map Ident Info
   }
 
@@ -126,10 +126,20 @@ extends :: ModuleInfo -> [ModuleName]
 extends = map fst . mextend
 
 isInherited :: MInclude -> Ident -> Bool
-isInherited c i = case c of
+isInherited c =
-  MIAll -> True
+  case c of
-  MIOnly is -> elem i is
+    MIAll -> const True
-  MIExcept is -> notElem i is
+    MIOnly is -> elemOrd is
+    MIExcept is -> not . elemOrd is
+
+-- | Faster version of `elem`, using a `Set`.
+-- Make sure you give this the first argument _outside_ of the inner loop
+--
+-- Example:
+-- > myIntersection xs ys = filter (elemOrd xs) ys
+elemOrd :: Ord a => [a] -> a -> Bool
+elemOrd list = (`Set.member` set)
+  where set = Set.fromList list
 
 inheritAll :: ModuleName -> (ModuleName,MInclude)
 inheritAll i = (i,MIAll)

src/compiler/GF/Grammar/Lexer.x

@@ -4,7 +4,7 @@
 module GF.Grammar.Lexer
          ( Token(..), Posn(..)
          , P, runP, runPartial, token, lexer, getPosn, failLoc
-         , isReservedWord
+         , isReservedWord, invMap
          ) where
 
 import Control.Applicative
@@ -134,7 +134,7 @@ data Token
  | T_Double  Double          -- double precision float literals
  | T_Ident   Ident
  | T_EOF
--- deriving Show -- debug
+  deriving (Eq, Ord, Show) -- debug
 
 res = eitherResIdent
 eitherResIdent :: (Ident -> Token) -> Ident -> Token
@@ -224,6 +224,13 @@ resWords = Map.fromList
  ]
  where b s t = (identS s, t)
 
+invMap :: Map.Map Token String
+invMap = res
+  where
+    lst = Map.toList resWords
+    flp = map (\(k,v) -> (v,showIdent k)) lst
+    res = Map.fromList flp
+
 unescapeInitTail :: String -> String
 unescapeInitTail = unesc . tail where
   unesc s = case s of
@@ -276,11 +283,11 @@ instance Functor P where
   fmap = liftA
 
 instance Applicative P where
-  pure = return
+  pure a = a `seq` (P $ \s -> POk s a)
   (<*>) = ap
 
 instance Monad P where
-  return a    = a `seq` (P $ \s -> POk s a)
+  return      = pure
   (P m) >>= k = P $ \ s -> case m s of
                              POk s a          -> unP (k a) s
                              PFailed posn err -> PFailed posn err

src/compiler/GF/Grammar/Parser.y

@@ -25,6 +25,7 @@ import GF.Compile.Update (buildAnyTree)
 import Data.List(intersperse)
 import Data.Char(isAlphaNum)
 import qualified Data.Map as Map
+import PGF(mkCId)
 
 }
 
@@ -36,6 +37,9 @@ import qualified Data.Map as Map
 %name pBNFCRules ListCFRule
 %name pEBNFRules ListEBNFRule
 
+%errorhandlertype explist
+%error { happyError }
+
 -- no lexer declaration
 %monad { P } { >>= } { return }
 %lexer { lexer } { T_EOF }
@@ -429,6 +433,7 @@ Exp3
                                          RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
                                          t          -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)]  }
   | Exp3 '**' Exp4                   { ExtR $1 $3    }
+  | Exp3 '**'  '{' ListCase '}'      { let v = identS "$vvv" in T TRaw ($4 ++ [(PV v, S $1 (Vr v))]) }
   | Exp4                             { $1            }
 
 Exp4 :: { Term }
@@ -624,7 +629,7 @@ ListCFRule
 
 CFRule :: { [BNFCRule] }
 CFRule
-  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
+  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
                                            }
   | Ident '::=' ListCFRHS ';'              { let { cat = showIdent $1;
                                                    mkFun cat its =
@@ -637,7 +642,7 @@ CFRule
                                                        Terminal    c     -> filter isAlphaNum c;
                                                        NonTerminal (t,_) -> t
                                                      }
-                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
+                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
                                            }
   | 'coercions' Ident Integer ';'          { [BNFCCoercions (showIdent $2) $3]}
   | 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }
@@ -700,8 +705,18 @@ Posn
 
 {
 
-happyError :: P a
+happyError :: (Token, [String]) -> P a
-happyError = fail "syntax error"
+happyError (t,strs) = fail $ 
+  "Syntax error:\n     Unexpected " ++ showToken t ++ ".\n     Expected one of:\n" 
+    ++ unlines (map (("     - "++).cleanupToken) strs)
+  
+  where
+    cleanupToken "Ident" = "an identifier"
+    cleanupToken x = x
+    showToken (T_Ident i) = "identifier '" ++ showIdent i ++ "'"
+    showToken t = case Map.lookup t invMap of 
+      Nothing -> show t
+      Just s -> "token '" ++ s ++"'"
 
 mkListId,mkConsId,mkBaseId  :: Ident -> Ident
 mkListId = prefixIdent "List"

src/compiler/GF/Grammar/Printer.hs

@@ -24,13 +24,13 @@ module GF.Grammar.Printer
            ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
-import PGF2 as PGF2
-import PGF2.Internal as PGF2
 import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.Values
 import GF.Grammar.Grammar
 
+import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
+
 import GF.Text.Pretty
 import Data.Maybe (isNothing)
 import Data.List  (intersperse)
@@ -362,40 +362,3 @@ 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/Infra/BuildInfo.hs

@@ -1,16 +1,43 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
 module GF.Infra.BuildInfo where
 import System.Info
 import Data.Version(showVersion)
 
+import Language.Haskell.TH.Syntax
+import Control.Monad.IO.Class
+import Control.Exception
+import Data.Time hiding (buildTime)
+import System.Process
+
+-- Use Template Haskell to get compile time
+buildTime :: String
+buildTime = $(do
+                 timeZone <- liftIO getCurrentTimeZone
+                 time <- liftIO $ utcToLocalTime timeZone <$> getCurrentTime
+                 return $ LitE $ StringL $ formatTime defaultTimeLocale "%F %T" time )
+
+-- Use Template Haskell to get current Git information
+gitInfo :: String
+gitInfo = $(do
+               info <- liftIO $ try $ readProcess "git" ["log", "--format=commit %h tag %(describe:tags=true)", "-1"] "" :: Q (Either SomeException String)
+               return $ LitE $ StringL $ either (\_ -> "unavailable") id info )
+
 {-# NOINLINE buildInfo #-}
 buildInfo =
     "Built on "++os++"/"++arch
-    ++" with "++compilerName++"-"++showVersion compilerVersion
+    ++" with "++compilerName++"-"++showVersion compilerVersion ++ " at " ++ buildTime ++ "\nGit info: " ++ gitInfo
-    ++", flags:"
+    ++"\nFlags:"
 #ifdef USE_INTERRUPT
     ++" interrupt"
 #endif
 #ifdef SERVER_MODE
     ++" server"
 #endif
+#ifdef NEW_COMP
+    ++" new-comp"
+#endif
+#ifdef C_RUNTIME
+    ++" c-runtime"
+#endif

src/compiler/GF/Infra/CheckM.hs

@@ -18,8 +18,8 @@ module GF.Infra.CheckM
            checkIn, checkInModule, checkMap, checkMapRecover,
            parallelCheck, accumulateError, commitCheck,
           ) where
-
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
 import GF.Data.Operations
 --import GF.Infra.Ident
 --import GF.Grammar.Grammar(msrc) -- ,Context
@@ -48,7 +48,7 @@ newtype Check a
 instance Functor Check where fmap = liftM
 
 instance Monad Check where
-  return x = Check $ \{-ctxt-} ws -> (ws,Success x)
+  return   = pure
   f >>= g  = Check $ \{-ctxt-} ws ->
                case unCheck f {-ctxt-} ws of
                  (ws,Success x) -> unCheck (g x) {-ctxt-} ws
@@ -58,7 +58,7 @@ instance Fail.MonadFail Check where
   fail = raise
 
 instance Applicative Check where
-  pure = return
+  pure x = Check $ \{-ctxt-} ws -> (ws,Success x)
   (<*>) = ap
 
 instance ErrorMonad Check where

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 Data.Binary(Binary(..))
+import PGF.Internal(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 ((<>))
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import GF.Text.Pretty
 
 -- ** Source locations

src/compiler/GF/Infra/Option.hs

@@ -34,14 +34,16 @@ import Data.Maybe
 import GF.Infra.Ident
 import GF.Infra.GetOpt
 import GF.Grammar.Predef
+--import System.Console.GetOpt
 import System.FilePath
-import PGF2.Internal(Literal(..))
+--import System.IO
 
 import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
 
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import PGF.Internal(Literal(..))
 import qualified Control.Monad.Fail as Fail
 
 usageHeader :: String
@@ -74,6 +76,7 @@ errors = raise . unlines
 
 data Mode = ModeVersion | ModeHelp
           | ModeInteractive | ModeRun
+          | ModeInteractive2 | ModeRun2
           | ModeCompiler
           | ModeServer {-port::-}Int
   deriving (Show,Eq,Ord)
@@ -92,6 +95,7 @@ data OutputFormat = FmtPGFPretty
                   | FmtPython
                   | FmtHaskell
                   | FmtJava
+                  | FmtProlog
                   | FmtBNF
                   | FmtEBNF
                   | FmtRegular
@@ -158,7 +162,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,
@@ -213,9 +217,10 @@ parseModuleOptions args = do
     then return opts
     else errors $ map ("Non-option among module options: " ++) nonopts
 
-fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
+fixRelativeLibPaths curr_dir lib_dirs (Options o) = Options (fixPathFlags . o)
   where
-    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
+    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [parent </> dir
+                                                                                      | parent <- curr_dir : lib_dirs]) path}
 
 -- Showing options
 
@@ -311,6 +316,8 @@ optDescr =
      Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
      Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
      Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
+     Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.",
+     Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).",
      Option [] ["server"] (OptArg modeServer "port") $
        "Run in HTTP server mode on given port (default "++show defaultPort++").",
      Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
@@ -425,7 +432,7 @@ optDescr =
        literalCat  x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
        lexicalCat  x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
        outDir      x = set $ \o -> o { optOutputDir = Just x }
-       gfLibPath   x = set $ \o -> o { optGFLibPath = Just x }
+       gfLibPath   x = set $ \o -> o { optGFLibPath = Just $ splitInModuleSearchPath x }
        gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
@@ -473,9 +480,12 @@ 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,6 +12,9 @@ module GF.Infra.SIO(
        newStdGen,print,putStr,putStrLn,
        -- ** Specific to GF
        importGrammar,importSource,
+#ifdef C_RUNTIME
+       readPGF2,
+#endif
        putStrLnFlush,runInterruptibly,lazySIO,
        -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
        -- | If the environment variable GF_RESTRICTED is defined, these
@@ -36,6 +39,9 @@ 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
@@ -46,11 +52,11 @@ newtype SIO a = SIO {unS::PutStr->IO a}
 instance Functor SIO where fmap = liftM
 
 instance Applicative SIO where
-  pure = return
+  pure x = SIO (const (pure x))
   (<*>) = ap
 
 instance Monad SIO where
-  return x = SIO (const (return x))
+  return         = pure
   SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
 
 instance Fail.MonadFail SIO where
@@ -121,3 +127,7 @@ lazySIO              = lift1   lazyIO
 
 importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
 importSource      opts files = lift0 $ GF.importSource      opts files
+
+#ifdef C_RUNTIME
+readPGF2 = lift0 . PGF2.readPGF
+#endif

src/compiler/GF/Infra/UseIO.hs

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

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(HasPGF(..),pgfCommands)
+import GF.Command.Commands(PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands)
 import GF.Command.CommonCommands(commonCommands,extend)
 import GF.Command.SourceCommands
 import GF.Command.CommandInfo
@@ -20,21 +20,29 @@ import GF.Infra.SIO
 import GF.Infra.Option
 import qualified System.Console.Haskeline as Haskeline
 
-import PGF2
+import PGF
+import PGF.Internal(abstract,funs,lookStartCat,emptyPGF)
 
 import Data.Char
 import Data.List(isPrefixOf)
 import qualified Data.Map as Map
 import qualified Text.ParserCombinators.ReadP as RP
+--import System.IO(utf8)
+--import System.CPUTime(getCPUTime)
 import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
 import Control.Exception(SomeException,fromException,evaluate,try)
 import Control.Monad.State hiding (void)
+import Control.Monad (join, when, (<=<))
 import qualified GF.System.Signal as IO(runInterruptibly)
 #ifdef SERVER_MODE
 import GF.Server(server)
 #endif
 
 import GF.Command.Messages(welcome)
+#if !(MIN_VERSION_base(4,9,0))
+-- Needed to make it compile on GHC < 8
+import Control.Monad.Trans.Instances ()
+#endif
 
 -- | Run the GF Shell in quiet mode (@gf -run@).
 mainRunGFI :: Options -> [FilePath] -> IO ()
@@ -275,18 +283,17 @@ importInEnv opts files =
      if flag optRetainResource opts
       then do src <- lift $ importSource opts files
               pgf <- lift . lazySIO $ importPGF pgf0 -- duplicates some work, better to link src
-              modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgf)}
+              modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgfEnv pgf)}
       else do pgf1 <- lift $ importPGF pgf0
               modify $ \ gfenv->gfenv { retain=False,
-                                        pgfenv = (emptyGrammar,pgf1) }
+                                        pgfenv = (emptyGrammar,pgfEnv pgf1) }
   where
     importPGF pgf0 =
       do let opts' = addOptions (setOptimization OptCSE False) opts
          pgf1 <- importGrammar pgf0 opts' files
          if (verbAtLeast opts Normal)
-           then case pgf1 of
+           then putStrLnFlush $
-                  Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
+                  unwords $ "\nLanguages:" : map showCId (languages pgf1)
-                  Nothing  -> return ()
            else return ()
          return pgf1
 
@@ -297,12 +304,12 @@ tryGetLine = do
    Right l -> return l
 
 prompt env
-  | retain env = "> "
+  | retain env || abs == wildCId = "> "
-  | otherwise  = case multigrammar env of
+  | otherwise      = showCId abs ++ "> "
-                   Just pgf -> abstractName pgf ++ "> "
+  where
-                   Nothing  -> "> "
+    abs = abstractName (multigrammar env)
 
-type CmdEnv = (Grammar,Maybe PGF)
+type CmdEnv = (Grammar,PGFEnv)
 
 data GFEnv = GFEnv {
     startOpts :: Options,
@@ -314,10 +321,10 @@ data GFEnv = GFEnv {
 
 emptyGFEnv opts = GFEnv opts False emptyCmdEnv emptyCommandEnv []
 
-emptyCmdEnv = (emptyGrammar,Nothing)
+emptyCmdEnv = (emptyGrammar,pgfEnv emptyPGF)
 
 emptyCommandEnv = mkCommandEnv allCommands
-multigrammar = snd . pgfenv
+multigrammar = pgf . snd . pgfenv
 
 allCommands =
   extend pgfCommands (helpCommand allCommands:moreCommands)
@@ -325,35 +332,24 @@ allCommands =
   `Map.union` commonCommands
 
 instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv)
-instance HasPGF ShellM where getPGF = gets (snd . pgfenv)
+instance HasPGFEnv ShellM where getPGFEnv = gets (snd . pgfenv)
 
 wordCompletion gfenv (left,right) = do
   case wc_type (reverse left) of
     CmplCmd pref
       -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
     CmplStr (Just (Command _ opts _)) s0
-      -> case multigrammar gfenv of
+      -> do mb_state0 <- try (evaluate (initState pgf (optLang opts) (optType opts)))
-           Just pgf -> let langs = languages pgf
+            case mb_state0 of
-                           optLang opts = case valStrOpts "lang" "" opts of
+              Right state0 -> let (rprefix,rs) = break isSpace (reverse s0)
-                                            ""   -> case Map.minView langs of
+                                  s            = reverse rs
-                                                      Nothing        -> Nothing
+                                  prefix       = reverse rprefix
-                                                      Just (concr,_) -> Just concr
+                                  ws           = words s
-                                            lang -> mplus (Map.lookup lang                       langs)
+                              in case loop state0 ws of
-                                                          (Map.lookup (abstractName pgf ++ lang) langs)
+                                   Nothing    -> ret 0 []
-                           optType opts = let readOpt str = case readType str of
+                                   Just state -> let compls = getCompletions state prefix
-                                                              Just ty -> case checkType pgf ty of
+                                                 in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls))
-                                                                           Left _   -> Nothing
+              Left (_ :: SomeException) -> ret 0 []
-                                                                           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]
@@ -364,15 +360,23 @@ wordCompletion gfenv (left,right) = do
     CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
       -> Haskeline.completeFilename (left,right)
     CmplIdent _ pref
-      -> case multigrammar gfenv of
+      -> do mb_abs <- try (evaluate (abstract pgf))
-           Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
+            case mb_abs of
-           Nothing  -> ret (length pref) []
+              Right abs -> ret (length pref) [Haskeline.simpleCompletion name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name]
+              Left (_ :: SomeException) -> ret (length pref) []
     _ -> ret 0 []
   where
+    pgf    = multigrammar gfenv
     cmdEnv = commandenv gfenv
+    optLang opts = valCIdOpts "lang" (head (languages pgf)) opts
+    optType opts =
+      let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
+      in case readType str of
+           Just ty -> ty
+           Nothing -> error ("Can't parse '"++str++"' as type")
 
     loop ps []     = Just ps
-    loop ps (t:ts) = case error "nextState ps (simpleParseInput t)" of
+    loop ps (t:ts) = case nextState ps (simpleParseInput t) of
                        Left  es -> Nothing
                        Right ps -> loop ps ts
 

src/compiler/GF/Interactive2.hs

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

src/compiler/GF/Main.hs

@@ -2,7 +2,10 @@
 {-# LANGUAGE CPP #-}
 module GF.Main where
 import GF.Compiler
-import GF.Interactive
+import qualified GF.Interactive as GFI1
+#ifdef C_RUNTIME
+import qualified GF.Interactive2 as GFI2
+#endif
 import GF.Data.ErrM
 import GF.Infra.Option
 import GF.Infra.UseIO
@@ -13,6 +16,7 @@ import Data.Version
 import System.Directory
 import System.Environment (getArgs)
 import System.Exit
+import GHC.IO.Encoding
 -- import GF.System.Console (setConsoleEncoding)
 
 -- | Run the GF main program, taking arguments from the command line.
@@ -20,6 +24,7 @@ import System.Exit
 -- Run @gf --help@ for usage info.
 main :: IO ()
 main = do
+  setLocaleEncoding utf8
   -- setConsoleEncoding
   uncurry mainOpts =<< getOptions
 
@@ -43,9 +48,22 @@ getOptions = do
 mainOpts :: Options -> [FilePath] -> IO ()
 mainOpts opts files =
     case flag optMode opts of
-      ModeVersion     -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
+      ModeVersion     -> do datadir <- getDataDir
+                            putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ 
+                                       buildInfo ++ "\n" ++
+                                       "Shared folder: " ++ datadir
       ModeHelp        -> putStrLn helpMessage
-      ModeServer port -> mainServerGFI opts port files
+      ModeServer port -> GFI1.mainServerGFI opts port files
       ModeCompiler    -> mainGFC opts files
-      ModeInteractive -> mainGFI opts files
+      ModeInteractive -> GFI1.mainGFI opts files
-      ModeRun         -> mainRunGFI opts files
+      ModeRun         -> GFI1.mainRunGFI opts files
+#ifdef C_RUNTIME
+      ModeInteractive2 -> GFI2.mainGFI opts files
+      ModeRun2         -> GFI2.mainRunGFI opts files
+#else
+      ModeInteractive2 -> noCruntime
+      ModeRun2         -> noCruntime
+  where
+    noCruntime = do ePutStrLn "GF configured without C run-time support"
+                    exitFailure
+#endif

src/compiler/GF/Quiz.hs

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

src/compiler/GF/Server.hs

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

src/compiler/GF/Speech/CFGToFA.hs

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

src/compiler/GF/Speech/GSL.hs

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

src/compiler/GF/Speech/JSGF.hs

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

src/compiler/GF/Speech/PGFToCFG.hs

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

src/compiler/GF/Speech/SISR.hs

@@ -10,9 +10,13 @@ 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
 
@@ -46,12 +50,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 n (map f ts)
+        f (CFObj n ts) = tree (showCId 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 typ)]
+        f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr (showCId typ))]
 
 fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$")
 fmtOut SISR_1_0 = JS.EVar (JS.Ident "out")

src/compiler/GF/Speech/SLF.hs

@@ -16,14 +16,17 @@ 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 PGF2
+import PGF
+--import PGF.CId
 
 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
@@ -40,7 +43,7 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
 
 type SLF_FA = FA State (Maybe CFSymbol) ()
 
-mkFAs :: PGF -> Concr -> (SLF_FA, [(String,SLF_FA)])
+mkFAs :: PGF -> CId -> (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
@@ -61,7 +64,7 @@ renameSubs (MFA start subs) = MFA (newName start) subs'
 -- * SLF graphviz printing (without sub-networks)
 --
 
-slfGraphvizPrinter :: PGF -> Concr -> String
+slfGraphvizPrinter :: PGF -> CId -> String
 slfGraphvizPrinter pgf cnc
     = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
   where 
@@ -71,7 +74,7 @@ slfGraphvizPrinter pgf cnc
 -- * SLF graphviz printing (with sub-networks)
 --
 
-slfSubGraphvizPrinter :: PGF -> Concr -> String
+slfSubGraphvizPrinter :: PGF -> CId -> String
 slfSubGraphvizPrinter pgf cnc = Dot.prGraphviz g
   where (main, subs) = mkFAs pgf cnc
         g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] 
@@ -97,7 +100,7 @@ gvSLFFA n fa =
 -- * SLF printing (without sub-networks)
 --
 
-slfPrinter :: PGF -> Concr -> String
+slfPrinter :: PGF -> CId -> String
 slfPrinter pgf cnc
     = prSLF $ automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' $ pgfToCFG pgf cnc
 
@@ -106,7 +109,7 @@ slfPrinter pgf cnc
 --
 
 -- | Make a network with subnetworks in SLF
-slfSubPrinter :: PGF -> Concr -> String
+slfSubPrinter :: PGF -> CId -> String
 slfSubPrinter pgf cnc = prSLFs slfs
   where 
   (main,subs) = mkFAs pgf cnc

src/compiler/GF/Speech/SRG.hs

@@ -17,15 +17,21 @@ module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), SRGItem, SRGSymbol
                      , lookupFM_
                      ) where
 
-import PGF2
+--import GF.Data.Operations
 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)
@@ -56,16 +62,16 @@ type SRGSymbol = Symbol SRGNT Token
 -- | An SRG non-terminal. Category name and its number in the profile.
 type SRGNT = (Cat, Int)
 
-ebnfPrinter :: Options -> PGF -> Concr -> String
+ebnfPrinter :: Options -> PGF -> CId -> String
 ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
 
 -- | Create a compact filtered non-left-recursive SRG.
-makeNonLeftRecursiveSRG :: Options -> PGF -> Concr -> SRG
+makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
 makeNonLeftRecursiveSRG opts = makeSRG opts'
     where
       opts' = setDefaultCFGTransform opts CFGNoLR True
 
-makeSRG :: Options -> PGF -> Concr -> SRG
+makeSRG :: Options -> PGF -> CId -> SRG
 makeSRG opts = mkSRG cfgToSRG preprocess
     where
       cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
@@ -91,7 +97,7 @@ stats g = "Categories: " ++ show (countCats g)
 -}
 makeNonRecursiveSRG :: Options
                     -> PGF
-                    -> Concr
+                    -> CId -- ^ Concrete syntax name.
                     -> SRG
 makeNonRecursiveSRG opts = mkSRG cfgToSRG id
     where
@@ -99,17 +105,17 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
           where
             MFA _ dfas = cfgToMFA cfg
             dfaToSRGItem = mapRE dummySRGNT . minimizeRE . dfa2re
-            dummyCFTerm = CFMeta "dummy"
+            dummyCFTerm = CFMeta (mkCId "dummy")
             dummySRGNT = mapSymbol (\c -> (c,0)) id
 
-mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> Concr -> SRG
+mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
 mkSRG mkRules preprocess pgf cnc =
-    SRG { srgName = concreteName cnc,
+    SRG { srgName = showCId cnc,
-	      srgStartCat = cfgStartCat cfg,
+          srgStartCat = cfgStartCat cfg,
           srgExternalCats = cfgExternalCats cfg,
-          srgLanguage = languageCode cnc,
+          srgLanguage = languageCode pgf cnc,
-	  srgRules = mkRules cfg }
+          srgRules = mkRules cfg }
-    where cfg = renameCats (concreteName cnc) $ preprocess $ pgfToCFG pgf cnc
+    where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
 
 -- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
 --   to C_N where N is an integer.

src/compiler/GF/Speech/SRGS_ABNF.hs

@@ -18,27 +18,31 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.SRGS_ABNF (srgsAbnfPrinter, srgsAbnfNonRecursivePrinter) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
-import Prelude hiding ((<>))
+--import GF.Data.Utilities
 import GF.Infra.Option
 import GF.Grammar.CFG
 import GF.Speech.SISR as SISR
 import GF.Speech.SRG
 import GF.Speech.RegExp
-import PGF2 (PGF,Concr)
+import PGF (PGF, CId)
 
+--import Data.Char
 import Data.List
 import Data.Maybe
 import GF.Text.Pretty
+--import Debug.Trace
 
 width :: Int
 width = 75
 
-srgsAbnfPrinter :: Options -> PGF -> Concr -> String
+srgsAbnfPrinter :: Options
+                -> PGF -> CId -> String
 srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
     where sisr = flag optSISR opts
 
-srgsAbnfNonRecursivePrinter :: Options -> PGF -> Concr -> String
+srgsAbnfNonRecursivePrinter :: Options -> PGF -> CId -> String
 srgsAbnfNonRecursivePrinter opts pgf cnc = showDoc $ prABNF Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 showDoc = renderStyle (style { lineLength = width })