for backwards compatibility, now a string literal is a sequence of any characters except space.

Majestic

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

@@ -2,7 +2,7 @@ name: Build Binary Packages
 
 on:
   workflow_dispatch:
-  release: 
+  release:
     types: ["created"]
 
 jobs:
@@ -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 \
-          libtool-bin
+          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,24 +111,24 @@ 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
-    
+
     - name: Rename package
       run: |
         mv dist/gf-*.pkg dist/gf-${{ github.event.release.tag_name }}-macos.pkg
 
-    - uses: actions/upload-release-asset@v1.0.2
+    #- 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-majestic.yml

@@ -2,19 +2,18 @@ name: Build majestic runtime
 
 on: push
 
-env:
-  LD_LIBRARY_PATH: /usr/local/lib
-
 jobs:
 
   linux-runtime:
     name: Runtime (Linux)
     runs-on: ubuntu-latest
     container:
-      image: quay.io/pypa/manylinux2014_x86_64:2024-01-08-eb135ed
+      image: quay.io/pypa/manylinux_2_28_x86_64
+    env:
+      LD_LIBRARY_PATH: /usr/local/lib
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
 
     - name: Build runtime
       working-directory: ./src/runtime/c
@@ -25,7 +24,7 @@ jobs:
         make install
 
     - name: Upload artifact
-      uses: actions/upload-artifact@v3
+      uses: actions/upload-artifact@v4
       with:
         name: libpgf-linux
         path: |
@@ -36,11 +35,13 @@ jobs:
     name: Haskell (Linux)
     runs-on: ubuntu-latest
     needs: linux-runtime
+    env:
+      LD_LIBRARY_PATH: /usr/local/lib
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
     - name: Download artifact
-      uses: actions/download-artifact@v3
+      uses: actions/download-artifact@v4
       with:
         name: libpgf-linux
     - run: |
@@ -48,7 +49,7 @@ jobs:
         sudo mv include/* /usr/local/include/
 
     - name: Setup Haskell
-      uses: haskell/actions/setup@v2
+      uses: haskell-actions/setup@v2
       with:
         ghc-version: 8
 
@@ -68,7 +69,7 @@ jobs:
         cabal v1-install
 
     - name: Upload artifact
-      uses: actions/upload-artifact@master
+      uses: actions/upload-artifact@v4
       with:
         name: compiler-linux
         path: |
@@ -78,11 +79,13 @@ jobs:
     name: Python (Linux)
     runs-on: ubuntu-latest
     needs: linux-runtime
+    env:
+      LD_LIBRARY_PATH: /usr/local/lib
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
     - name: Download artifact
-      uses: actions/download-artifact@v3
+      uses: actions/download-artifact@v4
       with:
         name: libpgf-linux
 
@@ -99,7 +102,7 @@ jobs:
       run: |
         python3 -m cibuildwheel src/runtime/python --output-dir wheelhouse
 
-    - uses: actions/upload-artifact@master
+    - uses: actions/upload-artifact@v4
       with:
         name: python-linux
         path: ./wheelhouse
@@ -110,7 +113,7 @@ jobs:
 #    needs: linux-runtime
 #
 #    steps:
-#    - uses: actions/checkout@v3
+#    - uses: actions/checkout@v7
 #    - name: Download artifact
 #      uses: actions/download-artifact@master
 #      with:
@@ -138,10 +141,12 @@ jobs:
 
   macos-runtime:
     name: Runtime (macOS)
-    runs-on: macOS-11
+    runs-on: macOS-latest
+    env:
+      LD_LIBRARY_PATH: /opt/homebrew/lib
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
 
     - name: Install build tools
       run: |
@@ -155,65 +160,91 @@ jobs:
       run: |
         glibtoolize
         autoreconf -i
-        ./configure
+        ./configure --prefix=/opt/homebrew
         make
         sudo make install
 
     - name: Upload artifact
-      uses: actions/upload-artifact@master
+      uses: actions/upload-artifact@v4
       with:
         name: libpgf-macos
         path: |
-          /usr/local/lib/libpgf*
+          /opt/homebrew/lib/libpgf*
-          /usr/local/include/pgf
+          /opt/homebrew/include/pgf
 
   macos-haskell:
     name: Haskell (macOS)
-    runs-on: macOS-11
+    runs-on: macOS-latest
     needs: macos-runtime
+    env:
+      LD_LIBRARY_PATH: /opt/homebrew/lib
+      CPATH: /opt/homebrew/include:$CPATH
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
     - name: Download artifact
-      uses: actions/download-artifact@master
+      uses: actions/download-artifact@v4
       with:
         name: libpgf-macos
     - run: |
-        sudo mv lib/* /usr/local/lib/
+        sudo mv lib/* /opt/homebrew/lib/
-        sudo mv include/* /usr/local/include/
+        sudo mv include/* /opt/homebrew/include/
 
     - name: Setup Haskell
-      uses: haskell/actions/setup@v2
+      uses: haskell-actions/setup@v2
       with:
-        ghc-version: 8
+        ghc-version: 9
 
-    - name: Build & run testsuite
+    - name: Install Haskell build tools
+      run: |
+        cabal v1-install alex happy
+
+    - name: build and test the runtime
       working-directory: ./src/runtime/haskell
       run: |
-        cabal test --extra-lib-dirs=/usr/local/lib
+        cabal v1-install --extra-lib-dirs=/opt/homebrew/lib --extra-include-dirs=/opt/homebrew/include
+        cabal test --extra-lib-dirs=/opt/homebrew/lib
+
+    - name: build the compiler
+      working-directory: ./src/compiler
+      run: |
+        cabal v1-install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@v4
+      with:
+        name: compiler-macos
+        path: |
+          ~/.cabal/bin/gf
 
   macos-python:
     name: Python (macOS)
-    runs-on: macOS-11
+    runs-on: macOS-latest
     needs: macos-runtime
     env:
-      EXTRA_INCLUDE_DIRS: /usr/local/include
+      LD_LIBRARY_PATH: /opt/homebrew/lib
-      EXTRA_LIB_DIRS: /usr/local/lib
+      EXTRA_INCLUDE_DIRS: /opt/homebrew/include
-      MACOSX_DEPLOYMENT_TARGET: 11.0
+      EXTRA_LIB_DIRS: /opt/homebrew/lib
+      MACOSX_DEPLOYMENT_TARGET: 26.0
   
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
     - name: Download artifact
-      uses: actions/download-artifact@master
+      uses: actions/download-artifact@v4
       with:
         name: libpgf-macos
     - run: |
-        sudo mv lib/* /usr/local/lib/
+        sudo mv lib/* /opt/homebrew/lib/
-        sudo mv include/* /usr/local/include/
+        sudo mv include/* /opt/homebrew/include/
+
+    - name: Create Python virtual environment
+      run: |
+        python3 -m venv .venv
+        .venv/bin/python -m pip install --upgrade pip
 
     - name: Install cibuildwheel
       run: |
-        python3 -m pip install git+https://github.com/joerick/cibuildwheel.git@main
+        .venv/bin/python -m pip install git+https://github.com/joerick/cibuildwheel.git@main
 
     - name: Install and test bindings
       env:
@@ -221,9 +252,9 @@ jobs:
         CIBW_TEST_COMMAND: "pytest {project}/src/runtime/python"
         CIBW_SKIP: "pp* cp36* cp37* cp38* cp39*"
       run: |
-        python3 -m cibuildwheel src/runtime/python --output-dir wheelhouse
+        .venv/bin/python -m cibuildwheel src/runtime/python --output-dir wheelhouse
 
-    - uses: actions/upload-artifact@master
+    - uses: actions/upload-artifact@v4
       with:
         name: python-macos
         path: ./wheelhouse
@@ -234,7 +265,7 @@ jobs:
 #    needs: macos-runtime
 #
 #    steps:
-#    - uses: actions/checkout@v3
+#    - uses: actions/checkout@v7
 #    - name: Download artifact
 #      uses: actions/download-artifact@master
 #      with:
@@ -265,7 +296,7 @@ jobs:
     runs-on: windows-latest
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
     
     - name: Setup MSYS2
       uses: msys2/setup-msys2@v2
@@ -289,7 +320,7 @@ jobs:
         make install
 
     - name: Upload artifact
-      uses: actions/upload-artifact@master
+      uses: actions/upload-artifact@v4
       with:
         name: libpgf-windows
         path: |
@@ -300,17 +331,65 @@ jobs:
           ${{runner.temp}}/msys64/mingw64/lib/libpgf*
           ${{runner.temp}}/msys64/mingw64/include/pgf
 
+  windows-haskell:
+    name: Haskell (Windows)
+    runs-on: windows-latest
+    needs: mingw64-runtime
+
+    steps:
+    - uses: actions/checkout@v7
+    - name: Download artifact
+      uses: actions/download-artifact@v4
+      with:
+        name: libpgf-windows
+
+    - name: Setup Haskell
+      uses: haskell-actions/setup@v2
+      with:
+        ghc-version: 8
+
+    - name: Install libpgf for GHC
+      shell: pwsh
+      run: |
+        $ghcLibDir = ghc --print-libdir
+
+        Copy-Item "${{ github.workspace }}\lib\*" "$ghcLibDir\..\mingw\lib\" -Force
+        Copy-Item "${{ github.workspace }}\include\pgf" "$ghcLibDir\..\mingw\include\" -Recurse -Force
+        Copy-Item "${{ github.workspace }}\bin\*" "$ghcLibDir\..\bin\" -Force
+
+    - name: Install Haskell build tools
+      run: |
+        cabal v1-install alex happy
+
+    - name: build and test the runtime
+      working-directory: ./src/runtime/haskell
+      run: |
+        cabal v1-install
+        cabal test
+
+    - name: build the compiler
+      working-directory: ./src/compiler
+      run: |
+        cabal v1-install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@v4
+      with:
+        name: compiler-windows
+        path: |
+          ~/.cabal/bin/gf
+
   windows-python:
     name: Python (Windows)
     runs-on: windows-latest
 
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v7
 
     - name: Setup Python
       uses: actions/setup-python@v4
       with:
-        python-version: '3.10'
+        python-version: '3.11'
 
     - name: Install cibuildwheel
       run: |
@@ -324,7 +403,7 @@ jobs:
       run: |
         python3 -m cibuildwheel src\runtime\python --output-dir wheelhouse
 
-    - uses: actions/upload-artifact@master
+    - uses: actions/upload-artifact@v4
       with:
         name: python-windows
         path: ./wheelhouse
@@ -336,7 +415,7 @@ jobs:
     if: github.ref == 'refs/heads/majestic' && github.event_name == 'push'
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v7
 
       - name: Set up Python
         uses: actions/setup-python@v3
@@ -346,17 +425,17 @@ jobs:
       - name: Install twine
         run: pip install twine
 
-      - uses: actions/download-artifact@master
+      - uses: actions/download-artifact@v4
         with:
           name: python-linux
           path: ./dist
 
-      - uses: actions/download-artifact@master
+      - uses: actions/download-artifact@v4
         with:
           name: python-macos
           path: ./dist
 
-      - uses: actions/download-artifact@master
+      - uses: actions/download-artifact@v4
         with:
           name: python-windows
           path: ./dist

.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

@@ -5,7 +5,6 @@
 *.jar
 *.gfo
 *.pgf
-*.ngf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf
@@ -47,8 +46,6 @@ src/runtime/c/sg/.dirstamp
 src/runtime/c/stamp-h1
 src/runtime/java/.libs/
 src/runtime/python/build/
-src/runtime/python/**/__pycache__/
-src/runtime/python/**/.pytest_cache/
 .cabal-sandbox
 cabal.sandbox.config
 .stack-work
@@ -56,12 +53,6 @@ DATA_DIR
 
 stack*.yaml.lock
 
-# Generated source files
-src/compiler/api/GF/Grammar/Lexer.hs
-src/compiler/api/GF/Grammar/Parser.hs
-src/compiler/api/PackageInfo_gf.hs
-src/compiler/api/Paths_gf.hs
-
 # Output files for test suite
 *.out
 gf-tests.html
@@ -82,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

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/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:
 ```
@@ -3733,7 +3746,7 @@ However, type-incorrect commands are rejected by the typecheck:
   The parsing is successful but the type checking failed with error(s):
     Couldn't match expected type Device light
        against the interred type Device fan
-    In the expression: DKindOne fan       
+    In the expression: DKindOne fan
 ```
 
 #NEW
@@ -4171,7 +4184,7 @@ division of integers.
 ```
   abstract Calculator = {
   flags startcat = Exp ;
-  
+
   cat Exp ;
 
   fun
@@ -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

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 = [ ];
+              });
+        });
+    };
+}

index.html

@@ -55,15 +55,14 @@
       <li><a href="gf-book">The GF Book</a></li>
       <li><a href="doc/gf-refman.html">Reference Manual</a></li>
       <li><a href="doc/gf-shell-reference.html">Shell Reference</a></li>
-      <li><a href="http://www.molto-project.eu/sites/default/files/MOLTO_D2.3.pdf">Best Practices</a> <small>[PDF]</small></li>
+      <li><a href="https://www.grammaticalframework.org/doc/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://github.com/GrammaticalFramework/gf-wordnet/blob/master/README.md">GF WordNet</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">
       <i class="fab fa-readme mr-1"></i>
-      RGL Synopsis
+      RGL API
     </a>
   </div>
 
@@ -73,8 +72,12 @@
       <li><a href="doc/gf-developers.html">Developers Guide</a></li>
       <!-- <li><a href="/~hallgren/gf-experiment/browse/">Browse Source Code</a></li> -->
       <li>PGF library API:<br>
-        <a href="http://hackage.haskell.org/package/gf/docs/PGF.html">Haskell</a> /
+        <ul>
-        <a href="doc/runtime-api.html">C&nbsp;runtime</a>
+          <li><a href="http://hackage.haskell.org/package/gf/docs/PGF.html">Haskell</a>
+          </li><li><a href="doc/runtime-api.html#python">Python</a>
+          </li><li><a href="doc/runtime-api.html">C&nbsp;runtime</a>
+          </li>
+        </ul>
       </li>
       <li><a href="http://hackage.haskell.org/package/gf/docs/GF.html">GF compiler API</a></li>
       <!-- <li><a href="src/ui/android/README">GF on Android (new)</a></li>
@@ -88,11 +91,6 @@
     <h3>Contribute</h3>
     <ul class="mb-2">
       <li>
-        <a href="https://web.libera.chat/?channels=#gf">
-          <i class="fas fa-hashtag"></i>
-          IRC
-        </a>
-        /
         <a href="https://discord.gg/EvfUsjzmaz">
           <i class="fab fa-discord"></i>
           Discord
@@ -106,7 +104,7 @@
       </li>
       <li><a href="https://groups.google.com/group/gf-dev">Mailing List</a></li>
       <li><a href="https://github.com/GrammaticalFramework/gf-core/issues">Issue Tracker</a></li>
-      <li><a href="//school.grammaticalframework.org/2020/">Summer School</a></li>
+      <li><a href="//school.grammaticalframework.org/">Summer School</a></li>
       <li><a href="doc/gf-people.html">Authors</a></li>
     </ul>
     <a href="https://github.com/GrammaticalFramework/" class="btn btn-primary ml-3">
@@ -233,14 +231,10 @@ 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>
-    There is also a <a href="https://discord.gg/EvfUsjzmaz">GF server on Discord</a>.
     </p>
 
+
     <p>
     For bug reports and feature requests, please create an issue in the
     <a href="https://github.com/GrammaticalFramework/gf-core/issues">GF Core</a> or
@@ -255,6 +249,19 @@ least one, it may help you to get a first idea of what GF is.
   <div class="col-md-6">
     <h2>News</h2>
     <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>
@@ -264,10 +271,6 @@ least one, it may help you to get a first idea of what GF is.
       <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.

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

src/compiler/api/GF/Command/Commands.hs

@@ -358,14 +358,16 @@ pgfCommands = Map.fromList [
        "See also the ps command for lexing and character encoding."
        ],
      exec = needPGF $ \opts ts pgf ->
-              return $
+              let parseOp | isOpt "robust" opts = \concr -> ParseOk . robustParse concr (optType pgf opts)
-                foldr (joinPiped . fromParse1 opts) void 
+                          | otherwise           = \concr -> parse concr (optType pgf opts)
-                  (concat [
+              in return $
-                              [(s,parse concr (optType pgf opts) s) |
+                   foldr (joinPiped . fromParse1 opts) void
-                                            concr <- optLangs pgf opts] 
+                     (concat [[(s,parseOp concr s) |
-                           | s <- toStrings ts]),
+                                           concr <- optLangs pgf opts]
+                              | s <- toStrings ts]),
      options = [
-       ("show_probs", "show the probability of each result")
+       ("show_probs", "show the probability of each result"),
+       ("robust",     "return a partial result for ungrammatical input")
        ],
      flags = [
        ("cat","target category of parsing"),
@@ -783,7 +785,7 @@ pgfCommands = Map.fromList [
    fromParse1 opts (s,po) =
      case po of
        ParseOk ts      -> fromExprs (isOpt "show_probs" opts) (takeOptNum opts ts)
-       ParseFailed i t -> pipeMessage $ "The parser failed at token "
+       ParseFailed i t -> pipeMessage $ "The parser failed at position "
                                         ++ show i ++": "
                                         ++ show t
        ParseIncomplete -> pipeMessage "The sentence is not complete"

src/compiler/api/GF/Command/Importing.hs

@@ -1,7 +1,7 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
 import PGF2
-import PGF2.Transactions
+import PGF2.Transactions hiding (Rule(..))
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)

src/compiler/api/GF/Command/SourceCommands.hs

@@ -19,8 +19,8 @@ import GF.Grammar.Analyse
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
-import GF.Compile.Compute.Concrete2(normalForm,normalFlatForm,Globals(..),stdPredef)
+import GF.Compile.Compute(normalForm,normalFlatForm,Globals(..),stdPredef)
-import GF.Compile.TypeCheck.Concrete as TC(inferLType)
+import GF.Compile.TypeCheck as TC(inferLType)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
 import GF.Command.CommandInfo
@@ -253,7 +253,7 @@ checkComputeTerm os sgr t =
     -- ** Try to compute pre{...} tokens in token sequences
     singleton x = [x]
 
-    g = Gl sgr (stdPredef g)
+    g = Gl sgr (stdPredef g) False
 
     evalStr t =
       case t of

src/compiler/api/GF/Compile/CFGtoPGF.hs

@@ -95,7 +95,7 @@ cf2concr opts abstr cfg =
 
     mkSequence rule = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
       where
-        convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
+        convertSymbol d (NonTerminal (c,_)) = (d+1,SymCat d 0)
         convertSymbol d (Terminal t)        = (d,  SymKS t)
 
     mkCncCat fid (cat,n)

src/compiler/api/GF/Compile/CheckGrammar.hs

@@ -26,13 +26,13 @@ import Prelude hiding ((<>))
 import GF.Infra.Ident
 import GF.Infra.Option
 
-import GF.Compile.TypeCheck.Abstract
+import GF.Compile.TypeCheck(checkLType,inferLType,checkContext,checkDef)
-import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
+import GF.Compile.Compute(normalForm,Globals(..),noPredef,stdPredef)
-import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
 
 import GF.Grammar
 import GF.Grammar.Lexer
 import GF.Grammar.Lookup
+import GF.Grammar.Lockfield
 
 import GF.Data.Operations
 import GF.Infra.CheckM
@@ -52,8 +52,8 @@ checkModule opts cwd sgr mo@(m,mi) = do
                              abs <- lookupModule gr a
                              checkCompleteGrammar opts cwd gr (a,abs) mo
           _            -> return mo
-  infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
+  infos <- checkInModule cwd mi NoLoc empty $ topoSortJments mo
-  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
+  foldM (checkInfo opts cwd sgr) mo infos
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
@@ -70,7 +70,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
      let incld c   = Set.member c (Set.fromList incl)
      let illegal c = Set.member c (Set.fromList excl)
      let illegals = [(f,is) |
-           (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
+           (f,_,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
      case illegals of
        [] -> return ()
        cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
@@ -92,7 +92,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
   where
    checkAbs js i@(c,info) =
      case info of
-       AbsFun (Just (L loc ty)) _ _ _
+       AbsFun (Just (L loc ty)) _
            -> do let mb_def = do
                        let (cxt,(_,i),_) = typeForm ty
                        info <- lookupIdent i js
@@ -134,7 +134,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
    checkCnc js (c,info) =
      case info of
        CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
+                             Ok (_,AbsFun (Just (L loc ty)) _) ->
                                         do linty <- linTypeOfType gr cm (L loc ty)
                                            return $ Map.insert c (CncFun (Just linty) d mn mf) js
                              _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
@@ -156,57 +156,69 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
   checkReservedId c
   case info of
     AbsCat (Just (L loc cont)) ->
-      mkCheck loc "the category" $
+      chIn loc "the category" $ do
-        checkContext gr cont
+        cont <- checkContext ga cont
+        update sm c (AbsCat (Just (L loc cont)))
 
-    AbsFun (Just (L loc typ)) ma md moper -> do
+    AbsFun (Just (L loc typ)) md -> do
-      mkCheck loc "the type of function" $
+      (typ,_) <- chIn loc "the type of function" $
-        checkTyp gr typ
+                   checkLType ga typ typeType
-      typ <- compAbsTyp [] typ   -- to calculate let definitions
+      typ <- normalForm ga typ   -- to calculate let definitions
-      case md of
+      sm <- update sm c (AbsFun (Just (L loc typ)) md)
-        Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
+      let gr' = prependModule sgr sm
-                                          checkDef gr (fst sm,c) typ eq) eqs
+          ga' = Gl gr' noPredef True
-        Nothing  -> return ()
+      md <- case md of
-      update sm c (AbsFun (Just (L loc typ)) ma md moper)
+              Just (_,eqs) -> do eqs <- mapM (\(L loc eq) -> chIn loc "the definition of function" $
+                                                            fmap (L loc) (checkDef ga (fst sm,c) typ eq)) eqs
+                                 arity <-
+                                    case [length ps | L _ (ps,_) <- eqs] of
+                                      []                   -> return 0
+                                      (arity : as) 
+                                        | all (==arity) as -> return arity
+                                      _ -> checkError ("The following equations have different arities" $$
+                                                       nest 4 (vcat [ppQIdent Unqualified (fst sm,c) <+> hsep (map (ppPatt Unqualified 2) ps) | L _ (ps,_) <- eqs]))
+                                 return (Just (arity,eqs))
+              Nothing  -> return Nothing
+      update sm c (AbsFun (Just (L loc typ)) md)
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
                 Just (L loc typ) -> chIn loc "linearization type of" $ do
-                                      (typ,_) <- checkLType g typ typeType
+                                      (typ,_) <- checkLType gc typ typeType
-                                      typ  <- normalForm g typ
+                                      typ  <- normalForm gc typ
                                       return (Just (L loc typ))
                 Nothing          -> return Nothing
       mdef <- case (mty,mdef) of
                 (Just (L _ typ),Just (L loc def)) ->
                     chIn loc "default linearization of" $ do
-                       (def,_) <- checkLType g def (mkFunType [typeStr] typ)
+                       (def,_) <- checkLType gc def (mkFunType [typeStr] typ)
                        return (Just (L loc def))
                 _ -> return Nothing
       mref <- case (mty,mref) of
                 (Just (L _ typ),Just (L loc ref)) ->
                     chIn loc "reference linearization of" $ do
-                       (ref,_) <- checkLType g ref (mkFunType [typ] typeStr)
+                       (ref,_) <- checkLType gc ref (mkFunType [typ] typeStr)
                        return (Just (L loc ref))
                 _ -> return Nothing
       mpr  <- case mpr of
                 (Just (L loc t)) ->
                     chIn loc "print name of" $ do
-                       (t,_) <- checkLType g t typeStr
+                       (t,_) <- checkLType gc t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
       update sm c (CncCat mty mdef mref mpr mpmcfg)
 
     CncFun mty mt mpr mpmcfg -> do
       mt <- case (mty,mt) of
-              (Just (_,cat,cont,val),Just (L loc trm)) ->
+              (Just (args,cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
-                     (trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
+                     (trm,_) <- checkLType gc trm (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) val)  -- erases arg vars
                      return (Just (L loc (etaExpand [] trm cont)))
               _ -> return mt
       mpr  <- case mpr of
                 (Just (L loc t)) ->
                     chIn loc "print name of" $ do
-                       (t,_) <- checkLType g t typeStr
+                       (t,_) <- checkLType gc t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
       update sm c (CncFun mty mt mpr mpmcfg)
@@ -215,30 +227,35 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       (pty', pde') <- case (pty,pde) of
          (Just (L loct ty), Just (L locd de)) -> do
            ty'     <- chIn loct "operation" $ do
-                         (ty,_) <- checkLType g ty typeType
+                         (ty,_) <- checkLType gc ty typeType
-                         normalForm g ty
+                         normalForm gc ty
            (de',_) <- chIn locd "operation" $
-                         checkLType g de ty'
+                         checkLType gc de ty'
            return (Just (L loct ty'), Just (L locd de'))
          (Nothing         , Just (L locd de)) -> do
            (de',ty') <- chIn locd "operation" $
-                          inferLType g de
+                          inferLType gc de
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
              checkError (pp "No definition given to the operation")
       update sm c (ResOper pty' pde')
 
-    ResOverload os tysts -> chIn NoLoc "overloading" $ do
+    ResOverload os tysts -> do
-      tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType g t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
+      tysts' <- forM tysts $ \(L locty ty, L loct t) -> do  -- return explicit ones
+                  (ty,_) <- chIn locty "overload" $
+                              checkLType gc ty typeType
+                  (t,ty) <- chIn loct  "overload" $
+                              checkLType gc t ty
+                  return (L locty ty,L loct t)
       tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
       tysts1 <- sequence
-                  [checkLType g tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
+                  [checkLType gc tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
       --checkUniq $
       --  sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
-      update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
+      update sm c (ResOverload os tysts')
 
     ResParam (Just (L loc pcs)) _ -> do
       (sm,cnt,ts,pcs) <- chIn loc "parameter type" $
@@ -248,12 +265,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
     _ ->  return sm
  where
    gr = prependModule sgr sm
-   g = Gl gr (stdPredef g)
+   ga = Gl gr noPredef True
+   gc = Gl gr (stdPredef gc) False
    chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
 
    mkParamValues sm         c cnt ts []           = return (sm,cnt,[],[])
    mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do
-     co <- mapM (\(b,v,ty) -> normalForm g ty >>= \ty -> return (b,v,ty)) co
+     co <- mapM (\(b,v,ty) -> normalForm gc ty >>= \ty -> return (b,v,ty)) co
      sm <- case lookupIdent p (jments mi) of
              Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt)
              Bad msg                   -> checkError (pp msg)
@@ -268,22 +286,6 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       | otherwise -> checkUniq $ y:xs
      _ -> return ()
 
-   mkCheck loc cat ss = case ss of
-     [] -> return sm
-     _ -> chIn loc cat $ checkError (vcat ss)
-
-   compAbsTyp g t = case t of
-     Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g
-     Let (x,(_,a)) b -> do
-       a' <- compAbsTyp g a
-       compAbsTyp ((x, a'):g) b
-     Prod b x a t -> do
-       a' <- compAbsTyp g a
-       t' <- compAbsTyp ((x,Vr x):g) t
-       return $ Prod b x a' t'
-     Abs _ _ _ -> return t
-     _ -> composOp (compAbsTyp g) t
-
    etaExpand xs t            []               = t
    etaExpand xs (Abs bt x t) (_        :cont) = Abs bt x (etaExpand (x:xs) t              cont)
    etaExpand xs t            ((bt,_,ty):cont) = Abs bt x (etaExpand (x:xs) (App t (Vr x)) cont)
@@ -330,4 +332,4 @@ linTypeOfType cnc m (L loc typ) = do
       lookupLincat cnc m c >>= normalForm g
      ,return defLinType
      ]
-   g = Gl cnc (stdPredef g)
+   g = Gl cnc (stdPredef g) False

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

@@ -1,23 +1,22 @@
 {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-}
 
-module GF.Compile.Compute.Concrete2
+module GF.Compile.Compute
            (Env, Scope, Value(..), Variants(..), OptionInfo(..),
-            ConstValue(..), Globals(..), PredefTable, EvalM,
+            ConstValue(..), Globals(..), PredefTable, EvalM(..),
             mapVariantsC, unvariants,
-            runEvalM, runEvalMWithInput, stdPredef, globals,
+            runEvalM, runEvalMWithInput, stdPredef, noPredef, globals,
-            PredefImpl, Predef(..), ($\),
+            PredefImpl, Predef, pdArity,
-            pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
             eval, apply, value2term, value2termM, value2string, value2int, value2float, value2expr, string2value, bubble, patternMatch, vtableSelect, State(..),
             newResiduation, checkpoint, getMeta, setMeta, MetaState(..), variants, try,
-            evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where
+            evalError, evalWarn, ppValue, Choice(..), unit, split, split3, split4, mapC, mapCM) where
 
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import GF.Infra.Ident
 import GF.Infra.CheckM
 import GF.Data.Operations(Err(..))
 import GF.Data.Utilities(maybeAt,splitAt',(<||>),anyM,secondM,bimapM)
-import GF.Grammar.Lookup(lookupResDef,lookupOrigInfo)
+import GF.Grammar.Lookup
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
 import GF.Grammar.Predef
@@ -37,31 +36,20 @@ import Data.Char
 import PGF2(Expr(..),Literal(..))
 
 type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value
-newtype Predef = Predef { runPredef :: PredefImpl }
+data Predef = Predef { predefArity :: Int, predefRun :: PredefImpl }
 
-infix 1 $\
+pdArity :: Int -> PredefImpl -> Predef
-
+pdArity n def = Predef n def
-($\) :: (Predef -> Predef) -> PredefImpl -> Predef
-k $\ f = k (Predef f)
-
-pdCanonicalArgs :: Bool -> Predef -> Predef
-pdCanonicalArgs flat def = Predef $ \g c args ->
-  if all (isCanonicalForm flat) args then runPredef def g c args else RunTime
-
-pdArity :: Int -> Predef -> Predef
-pdArity n def = Predef $ \g c args ->
-  case splitAt' n args of
-    Nothing -> RunTime
-    Just (usedArgs, remArgs) ->
-      runPredef def g c usedArgs <&> \v -> apply g v remArgs
 
 type Env  = [(Ident,Value)]
 type Scope = [(Ident,Value)]
 type PredefTable = Map.Map Ident Predef
-data Globals = Gl Grammar PredefTable
+data Globals = Gl Grammar PredefTable Bool {- True for abstract, False for concrete -}
 
 data Value
-  = VApp Choice QIdent [Value]
+  = VApp QIdent [Value]           -- application of a constructor
+  | VPAP Choice QIdent [Value]    -- partially applied function
+  | VConst QIdent [Value]         -- function application that cannot be evaluated
   | VMeta {-# UNPACK #-} !MetaId [Value]
   | VSusp {-# UNPACK #-} !MetaId (Value -> Value) [Value]
   | VGen  {-# UNPACK #-} !Int [Value]
@@ -87,9 +75,10 @@ data Value
   | VFV Choice (Variants Value)
   | VAlts Value [(Value, Value)]
   | VStrs [Value]
-  | VMarkup Ident [(Ident,Value)] [Value]
+  | VMarkup Ident [(Ident,Value)] [L Value]
   | VReset Ident (Maybe Value) Value (Maybe QIdent)
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
+  | VSymVar Int Int
   | VError Doc
   | VInts Integer Bool
 
@@ -126,7 +115,7 @@ isCanonicalForm True  (VFV {})            = False
 isCanonicalForm False (VFV c vs)          = all (isCanonicalForm False) (unvariants vs)
 isCanonicalForm flat  (VAlts d vs)        = all (isCanonicalForm flat . snd) vs
 isCanonicalForm flat  (VStrs vs)          = all (isCanonicalForm flat) vs
-isCanonicalForm flat  (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs
+isCanonicalForm flat  (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat . unLoc) vs
 isCanonicalForm flat  (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
 isCanonicalForm flat  _ = False
 
@@ -186,7 +175,14 @@ eval g env s (Prod b x t1 t2)[]
   | otherwise                   = let (s1,s2) = split s
                                   in VProd b x (eval g env s1 t1 []) (VClosure env s2 t2)
 eval g env s (Typed t ty)   vs  = eval g env s t vs
-eval g env s (RecType lbls) []  = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls) False
+eval g env c (RecType rs)   []  = VRecType
+                                      (mapC (\c (lbl,deps,ty) ->
+                                                   let v = case deps of
+                                                             [] -> eval g env c ty []
+                                                             xs -> VClosure env c (foldr (Abs Explicit) ty deps)
+                                                   in (lbl,True,v))
+                                            c rs)
+                                      False
 eval g env s (R as)         []  = VR (mapC (\s (lbl,(ty,t)) -> (lbl, eval g env s t [])) s as)
 eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl as of
                                                                  Nothing -> VError ("Missing value for label" <+> pp lbl $$
@@ -195,6 +191,7 @@ eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl a
                                       project (VFV s fvs)    = VFV s (fmap project fvs)
                                       project (VMeta i vs)   = VSusp i (\v -> project (apply g v vs)) []
                                       project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) []
+                                      project (VError msg)   = VError msg
                                       project v              = VP v lbl vs
                                   in project (eval g env s t [])
 eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
@@ -207,6 +204,8 @@ eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
                                       extend v1             (VMeta i vs)     = VSusp i (\v -> extend v1 (apply g v vs)) []
                                       extend (VSusp i k vs) v2               = VSusp i (\v -> extend (apply g (k v) vs) v2) []
                                       extend v1             (VSusp i k vs)   = VSusp i (\v -> extend v1 (apply g (k v) vs)) []
+                                      extend (VError msg)   v2               = VError msg
+                                      extend v1             (VError msg)     = VError msg
                                       extend v1             v2               = VExtR v1 v2
 
                                   in extend (eval g env s1 t1 []) (eval g env s2 t2 [])
@@ -224,15 +223,11 @@ eval g env s (S t1 t2)      vs  = let (!s1,!s2) = split s
                                       v0 = VS v1 v2 vs
 
                                       select (VT _  env s cs) = patternMatch g s v0 (map (\(p,t) -> (env,[p],v2:vs,t)) cs)
-                                      select (VV vty tvs)     = case value2termM False (map fst env) vty of
+                                      select (VV vty tvs)     = vtableSelect g v0 vty tvs v2 vs
-                                                                  EvalM f -> case f g (\x state xs ws -> Success (x:xs) ws) empty [] [] of
-                                                                               Fail   msg  ws -> VError msg
-                                                                               Success tys ws -> case tys of
-                                                                                                   [ty] -> vtableSelect g v0 ty tvs v2 vs
-                                                                                                   tys  -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs
                                       select (VFV i fvs)      = VFV i (fmap select fvs)
                                       select (VMeta i vs)     = VSusp i (\v -> select (apply g v vs)) []
                                       select (VSusp i k vs)   = VSusp i (\v -> select (apply g (k v) vs)) []
+                                      select (VError msg)     = VError msg
                                       select v1               = v0
                                           
                                       -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all
@@ -243,12 +238,13 @@ eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s
                                       in eval g ((x,eval g env s1 t1 []):env) s2 t2 vs
 eval g env c (Q q@(m,id))  vs
   | m == cPredef              = evalPredef g c id vs
+  | isAbstract                = evalAbsDef g c q  vs
   | otherwise                 = case lookupResDef gr q of
-                                  Ok t    -> eval g env c t vs
+                                  Ok t    -> eval g [] c t vs
                                   Bad msg -> error msg
   where
-    Gl gr predef = g
+    Gl gr predef isAbstract = g
-eval g env s (QC q)         vs  = VApp s q vs
+eval g env c (QC q)         vs  = VApp q vs
 eval g env s (C t1 t2)      []  = let (!s1,!s2) = split s
 
                                       concat v1           VEmpty = v1
@@ -259,6 +255,8 @@ eval g env s (C t1 t2)      []  = let (!s1,!s2) = split s
                                       concat v1     (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) []
                                       concat (VSusp i k vs)   v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) []
                                       concat v1   (VSusp i k vs) = VSusp i (\v -> concat v1 (apply g (k v) vs)) []
+                                      concat (VError msg)     v2 = VError msg
+                                      concat v1     (VError msg) = VError msg
                                       concat v1               v2 = VC v1 v2
 
                                   in concat (eval g env s1 t1 []) (eval g env s2 t2 [])
@@ -266,12 +264,12 @@ eval g env s (Glue t1 t2)   []  = let (!s1,!s2) = split s
 
                                       glue VEmpty        v             = v
                                       glue (VC v1 v2)    v             = VC v1 (glue v2 v)
-                                      glue (VApp c q []) v
+                                      glue (VApp q [])   v
-                                        | q == (cPredef,cNonExist)     = VApp c q []
+                                        | q == (cPredef,cNonExist)     = VApp q []
                                       glue v             VEmpty        = v
                                       glue v             (VC v1 v2)    = VC (glue v v1) v2
-                                      glue v             (VApp c q [])
+                                      glue v             (VApp q [])
-                                        | q == (cPredef,cNonExist)     = VApp c q []
+                                        | q == (cPredef,cNonExist)     = VApp q []
                                       glue (VStr s1)     (VStr s2)     = VStr (s1++s2)
                                       glue v             (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
                                       glue (VAlts d vas) (VStr s)      = pre d vas s
@@ -282,6 +280,8 @@ eval g env s (Glue t1 t2)   []  = let (!s1,!s2) = split s
                                       glue v1            (VMeta i vs)  = VSusp i (\v -> glue v1 (apply g v vs)) []
                                       glue (VSusp i k vs) v2           = VSusp i (\v -> glue (apply g (k v) vs) v2) []
                                       glue v1            (VSusp i k vs)= VSusp i (\v -> glue v1 (apply g (k v) vs)) []
+                                      glue (VError msg)  v2            = VError msg
+                                      glue v1            (VError msg)  = VError msg
                                       glue v1            v2            = VGlue v1 v2
 
                                       pre vd []                 s              = glue vd (VStr s)
@@ -294,7 +294,7 @@ eval g env s (EPatt min max p) [] = VPatt min max p
 eval g env s (EPattType t)  []  = VPattType (eval g env s t [])
 eval g env s (ELincat c ty) []  = let lbl = lockLabel c
                                       lty = RecType []
-                                  in eval g env s (ExtR ty (RecType [(lbl,lty)])) []
+                                  in eval g env s (ExtR ty (RecType [(lbl,[],lty)])) []
 eval g env s (ELin c t)     []  = let lbl = lockLabel c
                                       lt  = R []
                                   in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) []
@@ -308,10 +308,11 @@ eval g env c (Strs ts)      []  = VStrs (mapC (\c t -> eval g env c t []) c ts)
 eval g env c (Markup tag as ts) [] =
                               let (c1,c2) = split c
                                   vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as
-                                  vs  = mapC (\c t -> eval g env c t []) c2 ts
+                                  vs  = mapC (\c (L loc t) -> L loc (eval g env c t [])) c2 ts
                               in (VMarkup tag vas vs)
 eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
 eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
+eval g env c (TSymVar d j)    []= VSymVar d j
 eval g env c t@(Opts n cs)  vs  = if null cs
                                   then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
                                   else let (c1,c2,c3) = split3 c
@@ -320,51 +321,71 @@ eval g env c t@(Opts n cs)  vs  = if null cs
                                        in VFV c3 (VarOpts vn vcs)
   where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
         evalOpt c' (Nothing,t) = let v = eval g env c' t vs in (v, v)
-eval g env c t              vs  = VError ("Cannot reduce term" <+> pp t)
+eval g env c t              vs = VError ("Cannot reduce term" <+> pp t)
 
 evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
-evalPredef g@(Gl gr pds) c n args =
+evalPredef g@(Gl gr pds _) c n args =
   case Map.lookup n pds of
-    Nothing  -> VApp c (cPredef,n) args
+    Nothing             -> VApp (cPredef,n) args
-    Just def -> let valueOf (Const res) = res
+    Just (Predef k def) -> case splitAt' k args of
-                    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
+                             Nothing -> VPAP c (cPredef,n) args
-                    valueOf (CSusp i k) = VSusp i (valueOf . k) []
+                             Just (usedArgs, remArgs) ->
-                    valueOf RunTime     = VApp c (cPredef,n) args
+                                apply g (valueOf (def g c usedArgs)) remArgs
-                    valueOf NonExist    = VApp c (cPredef,cNonExist) []
+  where
-                in valueOf (runPredef def g c args)
+    valueOf (Const res) = res
+    valueOf (CFV i vs)  = VFV i (fmap valueOf vs)
+    valueOf (CSusp i k) = VSusp i (valueOf . k) []
+    valueOf RunTime     = VConst (cPredef,n) args
+    valueOf NonExist    = VApp (cPredef,cNonExist) []
+
+noPredef :: PredefTable
+noPredef = Map.empty
 
 stdPredef :: Globals -> PredefTable
 stdPredef g = Map.fromList
-  [(cInts,   pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp c (cPredef,cInts) vs}))
+  [(cInts,   pdArity 1 $ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp (cPredef,cInts) vs}))
-  ,(cLength, pdArity 1 $\ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
+  ,(cLength, pdArity 1 $ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
-  ,(cTake,   pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2)))
+  ,(cTake,   pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2)))
-  ,(cDrop,   pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2)))
+  ,(cDrop,   pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2)))
-  ,(cTk,     pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTk (value2int g v1) (value2string g v2)))
+  ,(cTk,     pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericTk (value2int g v1) (value2string g v2)))
-  ,(cDp,     pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDp (value2int g v1) (value2string g v2)))
+  ,(cDp,     pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericDp (value2int g v1) (value2string g v2)))
-  ,(cIsUpper,pdArity 1 $\ \g c [v]     -> fmap toPBool (liftA (all isUpper) (value2string g v)))
+  ,(cIsUpper,pdArity 1 $ \g c [v]     -> fmap toPBool (liftA (all isUpper) (value2string g v)))
-  ,(cToUpper,pdArity 1 $\ \g c [v]     -> fmap string2value (liftA (map toUpper) (value2string g v)))
+  ,(cToUpper,pdArity 1 $ \g c [v]     -> fmap string2value (liftA (map toUpper) (value2string g v)))
-  ,(cToLower,pdArity 1 $\ \g c [v]     -> fmap string2value (liftA (map toLower) (value2string g v)))
+  ,(cToLower,pdArity 1 $ \g c [v]     -> fmap string2value (liftA (map toLower) (value2string g v)))
-  ,(cEqStr,  pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2string g v1) (value2string g v2)))
+  ,(cEqStr,  pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2string g v1) (value2string g v2)))
-  ,(cOccur,  pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 occur (value2string g v1) (value2string g v2)))
+  ,(cOccur,  pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 occur (value2string g v1) (value2string g v2)))
-  ,(cOccurs, pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 occurs (value2string g v1) (value2string g v2)))
+  ,(cOccurs, pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 occurs (value2string g v1) (value2string g v2)))
-  ,(cEqInt,  pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2int g v1) (value2int g v2)))
+  ,(cEqInt,  pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2int g v1) (value2int g v2)))
-  ,(cLessInt,pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (<) (value2int g v1) (value2int g v2)))
+  ,(cLessInt,pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (<) (value2int g v1) (value2int g v2)))
-  ,(cPlus,   pdArity 2 $\ \g c [v1,v2] -> fmap VInt (liftA2 (+) (value2int g v1) (value2int g v2)))
+  ,(cPlus,   pdArity 2 $ \g c [v1,v2] -> fmap VInt (liftA2 (+) (value2int g v1) (value2int g v2)))
-  ,(cError,  pdArity 1 $\ \g c [v]     -> fmap (VError . pp) (value2string g v))
+  ,(cError,  pdArity 1 $ \g c [v]     -> fmap (VError . pp) (value2string g v))
   ]
   where
     genericTk n = reverse . genericDrop n . reverse
     genericDp n = reverse . genericTake n . reverse
 
+evalAbsDef :: Globals -> Choice -> QIdent -> [Value] -> Value
+evalAbsDef g@(Gl gr pds _) c q args =
+  case lookupAbsDef gr q of
+    Ok (Just (arity,eqs)) ->
+      case splitAt' arity args of
+        Nothing -> VPAP c q args
+        Just (_,_) -> patternMatch g c (VConst q args) (map (\(ps,t) -> ([],ps,args,t)) eqs)
+    Ok Nothing -> VApp q args
+    Bad msg -> error msg
+
 apply g (VMeta i vs0)                   vs  = VMeta i   (vs0++vs)
 apply g (VSusp i k vs0)                 vs  = VSusp i k (vs0++vs)
-apply g (VApp c f@(m,n)  vs0)           vs
+apply g (VApp f vs0)                    vs  = VApp f (vs0++vs)
+apply g (VPAP c q@(m,n) vs0)            vs
   | m == cPredef                            = evalPredef g c n (vs0++vs)
-  | otherwise                               = VApp c f (vs0++vs)
+  | otherwise                               = evalAbsDef g c q (vs0++vs)
-apply g (VGen i  vs0)                   vs  = VGen i (vs0++vs)
+apply g (VConst f vs0)                  vs  = VConst f (vs0++vs)
+apply g (VGen i vs0)                    vs  = VGen i (vs0++vs)
 apply g (VFV i fvs)                     vs  = VFV i (fmap (\v -> apply g v vs) fvs)
 apply g (VS v1 v2 vs')                  vs  = VS v1 v2 (vs'++vs)
 apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
+apply g (VError msg)                    _   = VError msg
 apply g v                               []  = v
 
 data BubbleVariants
@@ -373,7 +394,9 @@ data BubbleVariants
 
 bubble v = snd (bubble v)
   where
-    bubble (VApp c f vs) = liftL (VApp c f) vs
+    bubble (VApp f vs) = liftL (VApp f) vs
+    bubble (VPAP c f vs) = liftL (VPAP c f) vs
+    bubble (VConst f vs) = liftL (VConst f) vs
     bubble (VMeta metaid vs) = liftL (VMeta metaid) vs
     bubble (VSusp metaid k vs) = liftL (VSusp metaid k) vs
     bubble (VGen i vs) = liftL (VGen i) vs
@@ -410,7 +433,7 @@ bubble v = snd (bubble v)
     bubble (VStrs vs) = liftL VStrs vs
     bubble (VMarkup tag attrs vs) =
       let (union1,attrs') = mapAccumL descend' Map.empty attrs
-          (union2,vs')    = mapAccumL descend  union1 vs
+          (union2,vs')    = mapAccumL descendL union1 vs
       in (union2, VMarkup tag attrs' vs')
     bubble (VReset ctl mb_cv v id) =
       let (union,v') = bubble v
@@ -418,6 +441,7 @@ bubble v = snd (bubble v)
     bubble (VSymCat d i0 vs) =
       let (union,vs') = mapAccumL descendC Map.empty vs
       in (union, addVariants (VSymCat d i0 vs') union)
+    bubble v@(VSymVar _ _) = lift0 v
     bubble v@(VError _) = lift0 v
     bubble v@(VInts _ _) = lift0 v
 
@@ -481,6 +505,10 @@ bubble v = snd (bubble v)
       let (choices,v') = bubble v
       in (mergeChoices1 union choices,(i,(v',ty)))
 
+    descendL union (L loc v) =
+      let (choices,v') = bubble v
+      in (mergeChoices1 union choices,L loc v')
+
     descendR union (l,b,v) =
       let (choices,v') = bubble v
       in (mergeChoices1 union choices,(l,b,v'))
@@ -497,8 +525,8 @@ bubble v = snd (bubble v)
     mergeChoices1 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,cnt+1)) id unitfy
     mergeChoices2 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,2)) unitfy unitfy
 
-toPBool True  = VApp poison (cPredef,cPTrue)  []
+toPBool True  = VApp (cPredef,cPTrue)  []
-toPBool False = VApp poison (cPredef,cPFalse) []
+toPBool False = VApp (cPredef,cPFalse) []
 
 occur s1 []          = False
 occur s1 s2@(_:tail) = check s1 s2
@@ -534,20 +562,26 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
                                                                                         (pp t))
                                                  Bad msg -> error msg
                                                where
-                                                 Gl gr _ = g
+                                                 Gl gr _ _ = g
-    match env (PV v      :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args
+    match env (PV v      :ps) eqs (arg:args)
+      | v == identW                          = match          env  ps eqs args
+      | otherwise                            = match ((v,arg):env) ps eqs args
     match env (PAs v p   :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args)
-    match env (PW        :ps) eqs (arg:args) = match env ps eqs args
     match env (PTilde _  :ps) eqs (arg:args) = match env ps eqs args
     match env (p         :ps) eqs (arg:args) = match' env p ps eqs arg args
 
     match' env p ps eqs arg args =
       case (p,arg) of
+        (p,       VConst q  vs) -> v0
         (p,       VMeta i   vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) []
         (p,       VGen  i   vs) -> v0
         (p,       VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) []
         (p,           VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs)
-        (PP q qs,  VApp c r vs)
+        (p,           VP _ _ _) -> v0
+        (p,           VS _ _ _) -> v0
+        (p,      VSymCat _ _ _) -> v0
+        (p,        VSymVar _ _) -> v0
+        (PP q qs, VApp r    vs)
           | q == r              -> match env (qs++ps) eqs (vs++args)
         (PR pas,  VR as)        -> matchRec env (reverse pas) as ps eqs args
         (PString s1, VStr s2)
@@ -555,24 +589,27 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
         (PString s1, VEmpty)
           | null s1             -> match env ps eqs args
         (PSeq min1 max1 p1 min2 max2 p2,v)
-                          -> case value2string g v of
+                    -> let match_seq (Const str) = let n  = length str
-                               Const str -> let n  = length str
+                                                       lo = min1 `max` (n-fromMaybe n max2)
-                                                lo = min1 `max` (n-fromMaybe n max2)
+                                                       hi = (n-min2) `min` fromMaybe n max1
-                                                hi = (n-min2) `min` fromMaybe n max1
+                                                       (ds,cs) = splitAt lo str
-                                                (ds,cs) = splitAt lo str
 
-                                                eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
+                                                       eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
-
+                                                   in patternMatch g s v0 eqs'
-                                            in patternMatch g s v0 eqs'
+                           match_seq (CSusp i k) = VSusp i (match_seq . k) []
-                               RunTime   -> v0
+                           match_seq (CFV c vs)  = VFV c (fmap match_seq vs)
-                               NonExist  -> patternMatch g s v0 eqs
+                           match_seq RunTime     = v0
+                           match_seq NonExist    = patternMatch g s v0 eqs
+                       in match_seq (value2string g v)
         (PRep minp maxp p, v)
-                          -> case value2string g v of
+                    -> let match_rep (Const str) = let n = length (str::String) `div` (max minp 1)
-                               Const str -> let n = length (str::String) `div` (max minp 1)
+                                                       eqs' = matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
-                                                eqs' = matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
+                                                   in patternMatch g s v0 eqs'
-                                            in patternMatch g s v0 eqs'
+                           match_rep (CSusp i k) = VSusp i (match_rep . k) []
-                               RunTime   -> v0
+                           match_rep (CFV c vs)  = VFV c (fmap match_rep vs)
-                               NonExist  -> patternMatch g s v0 eqs
+                           match_rep RunTime     = v0
+                           match_rep NonExist    = patternMatch g s v0 eqs
+                       in match_rep (value2string g v)
         (PChar, VStr [_]) -> match env ps eqs args
         (PChars cs, VStr [c])
           | elem c cs     -> match env ps eqs args
@@ -608,19 +645,19 @@ vtableSelect g v0 ty cs v2 vs =
     select (CFV c vs)    = VFV c (fmap select vs)
     select _             = v0
 
-    value2index (VMeta i vs)      ty = CSusp i (\v -> value2index (apply g v vs) ty)
+    value2index (VMeta i vs)      vty = CSusp i (\v -> value2index (apply g v vs) vty)
-    value2index (VSusp i k vs)    ty = CSusp i (\v -> value2index (apply g (k v) vs) ty)
+    value2index (VSusp i k vs)    vty = CSusp i (\v -> value2index (apply g (k v) vs) vty)
-    value2index (VR as) (RecType lbls) = compute lbls
+    value2index (VR as) (VRecType lbls _) = compute lbls
       where
-        compute []              = pure (0,1)
+        compute []                 = pure (0,1)
-        compute ((lbl,ty):lbls) =
+        compute ((lbl,_,vty):lbls) =
           case lookup lbl as of
             Just v  -> liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
-                              (value2index v ty)
+                              (value2index v vty)
                               (compute lbls)
             Nothing -> error (show ("Missing value for label" <+> pp lbl $$
                                     "among" <+> hsep (punctuate (pp ',') (map fst as))))
-    value2index (VApp c q args) ty =
+    value2index (VApp q args) vty =
       let (r ,ctxt,cnt ) = getIdxCnt q
       in fmap (\(r', cnt') -> (r+r',cnt)) (compute ctxt args)
       where
@@ -633,7 +670,7 @@ vtableSelect g v0 ty cs v2 vs =
         compute []              []     = pure (0,1)
         compute ((_,_,ty):ctxt) (v:vs) =
           liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt'))
-                 (value2index v ty)
+                 (value2index v (eval g [] unit ty []))
                  (compute ctxt vs)
 
         getInfo :: QIdent -> (ModuleName,Info)
@@ -642,11 +679,11 @@ vtableSelect g v0 ty cs v2 vs =
             Ok res  -> res
             Bad msg -> error msg
 
-        Gl gr _ = g
+        Gl gr _ _ = g
-    value2index (VInt n)          ty
+    value2index (VInt n) (VApp c [VInt max])
-      | Just max <- isTypeInts ty    = Const (fromIntegral n,fromIntegral max+1)
+      | Q c == cnPredef cInts         = Const (fromIntegral n,fromIntegral max+1)
-    value2index (VFV c vs)        ty = CFV c (fmap (\v -> value2index v ty) vs)
+    value2index (VFV c vs)        vty = CFV c (fmap (\v -> value2index v vty) vs)
-    value2index v ty = RunTime
+    value2index v vty = RunTime
 
 
 value2term :: Globals -> [Ident] -> Value -> Check Term
@@ -658,7 +695,7 @@ value2term g xs v = do
 
 data MetaState
   = Bound Scope Value
-  | Narrowing   Type
+  | Narrowing   Choice Type
   | Residuation Scope
 data OptionInfo
   = OptionInfo
@@ -805,8 +842,12 @@ setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs ->
   in k () state' r msgs)
 
 value2termM :: Bool -> [Ident] -> Value -> EvalM Term
-value2termM flat xs (VApp c q vs) =
+value2termM flat xs (VApp q vs) =
-  foldM (\t v -> fmap (App t) (value2termM flat xs v)) (if fst q == cPredef then Q q else QC q) vs
+  vapp2termM flat xs q (QC q) vs
+value2termM flat xs (VPAP _ q vs) =
+  vapp2termM flat xs q (Q q) vs
+value2termM flat xs (VConst q vs) =
+  vapp2termM flat xs q (Q q) vs
 value2termM flat xs (VMeta i vs) = do
   mv <- getMeta i
   case mv of
@@ -835,9 +876,16 @@ value2termM flat xs (VProd b x v1 v2) = do
   t1 <- value2termM flat xs v1
   t2 <- value2termM flat xs v2
   return (Prod b x t1 t2)
-value2termM flat xs (VRecType lbls _) = do
+value2termM flat xs (VRecType lbls ext) = do
-  lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
+  g <- globals
+  lbls <- mapM (\(lbl,_,v) -> uncover g lbl xs v) lbls
   return (RecType lbls)
+  where
+    uncover g lbl xs (VClosure env c (Abs b x t)) = do (lbl,deps,t) <- uncover g lbl (x:xs) (VClosure ((x,VGen (length xs) []):env) c t)
+                                                       return (lbl,x:deps,t)
+    uncover g lbl xs (VClosure env c t)           = fmap ((,,) lbl []) (value2termM flat xs (eval g env c t []))
+    uncover g lbl xs v                            = fmap ((,,) lbl []) (value2termM flat xs v)
+
 value2termM flat xs (VR as) = do
   as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as
   return (R as)
@@ -934,7 +982,7 @@ value2termM flat xs (VStrs vs) = do
   return (Strs ts)
 value2termM flat xs (VMarkup tag as vs) = do
   as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
-  ts <- mapM (value2termM flat xs) vs
+  ts <- mapM (mapM (value2termM flat xs)) vs
   return (Markup tag as ts)
 value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
   ts <- reset (value2termM True xs v)
@@ -948,7 +996,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                  _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
          case ts of
            [t] -> return t
-           ts  -> return (Markup identW [] ts)
+           ts  -> return (Markup identW [] (map noLoc ts))
       | ctl == cConcat' = do
          ts <- case mb_cv of
                  Just (VInt n) -> return (genericTake n ts)
@@ -957,7 +1005,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
          case ts of
            []  -> mzero
            [t] -> return t
-           ts  -> return (Markup identW [] ts)
+           ts  -> return (Markup identW [] (map noLoc ts))
       | ctl == cOne =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -979,6 +1027,16 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                                _    -> evalError (pp "The term must be a record")
                            select n (t:ts) = select (n-1) ts
            _             -> evalError (pp "[select: .. | ..] requires an integer constant")
+      | ctl == cFilter =
+          let filter []     = mzero
+              filter (t:ts) =
+                case t of
+                  R rs -> case (lookup (ident2label cp1) rs, lookup (ident2label cp2) rs) of
+                            (Just (_,t), Just (_,Q q))
+                                | q == (cPredef,cTrue) -> pure t `mplus` filter ts
+                            _                          ->                filter ts
+                  _    -> evalError (pp "The term must be a record")
+          in filter ts
       | ctl == cDefault =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -1000,6 +1058,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
            Just cv  -> do g <- globals
                           value2termM True xs (apply g cv [VInt (genericLength ts)])
            Nothing  -> return (EInt (genericLength ts))
+      | ctl == cConst =
+          case mb_cv of
+            Just cv -> do ct <- value2termM flat xs cv
+                          msum (map (pure . const ct) ts)
+            _       -> evalError (pp "[const: .. | ..] requires an argument")
       | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 
     listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)
@@ -1014,6 +1077,18 @@ value2termM flat xs (VError msg) = evalError msg
 value2termM flat xs (VInts n _) = return (App (Q (cPredef,cInts)) (EInt n))
 value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v)
 
+vapp2termM flat xs q t vs = do
+  g@(Gl gr _ isAbstract) <- globals
+  case (if isAbstract then fmap snd (lookupAbsType gr q) else lookupResType gr q) of
+    Bad msg -> evalError (pp msg)
+    Ok ty   -> do (t,_) <- foldM app (t,ty) vs
+                  return t
+  where
+    app (t,Prod bt _ _ ty) v = do
+      arg <- value2termM flat xs v
+      case bt of
+        Explicit -> return (App t arg,ty)
+        Implicit -> return (App t (ImplArg arg),ty)
 
 pattVars st (PP _ ps)    = foldl pattVars st ps
 pattVars st (PV x)       = case st of
@@ -1028,10 +1103,23 @@ pattVars st _            = st
 
 
 
-ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VApp f vs)
-ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
+  | null vs   = ppQIdent q f
+  | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VPAP _ f vs)
+  | null vs   = ppQIdent q f
+  | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VConst f vs)
+  | null vs   = ppQIdent q f
+  | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
+ppValue q d (VMeta i vs)
+  | null vs   = meta
+  | otherwise = prec d 4 (hsep (meta : map (ppValue q 5) vs))
+  where
+    meta | i > 0     = pp "?" <> pp i
+         | otherwise = pp "?"
 ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
-ppValue q d (VGen _ _) = pp "VGen"
+ppValue q d (VGen i vs) = prec d 4 (hsep (pp "#gen" : pp i : map (ppValue q 5) vs))
 ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]"
 ppValue q d (VProd bt x a b) =
   if x == identW && bt == Explicit
@@ -1043,8 +1131,9 @@ ppValue q d (VRecType xs ext)
                            _     -> doc
   | otherwise          = doc
   where
-    doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
+    doc  = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
-ppValue q d (VR _) = pp "VR"
+ppValue q d (VR [])     = pp "<>" -- to distinguish from {} empty RecType
+ppValue q d (VR xs)     = braces (fsep (punctuate ';' [l <+> '=' <+> ppValue q 0 v | (l,v) <- xs]))
 ppValue q d (VP v l vs) = prec d 5 (hsep (ppValue q 5 v <> '.' <> l : map (ppValue q 5) vs))
 ppValue q d (VExtR _ _) = pp "VExtR"
 ppValue q d (VTable kt vt) = prec d 0 (ppValue q 3 kt <+> "=>" <+> ppValue q 0 vt)
@@ -1073,6 +1162,7 @@ ppValue q d (VReset ctl ct t _) = pp "[" <> pp ctl <>
                                   pp "|" <> ppValue q 0 t <>
                                   pp "]"
 ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
+ppValue q d (VSymVar i j)    = pp '<' <> pp i <> pp ',' <> pp '$' <> pp j <> pp '>'
 ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
 ppValue q d (VInts n ext)
   | ext       = prec d 4 (pp "Ints" <+> brackets (pp n <> ".."))
@@ -1096,24 +1186,24 @@ value2string' g (VC v1 v2)       b ws      qs = concat v1 (value2string' g v2 b
     concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs
     concat v1 (CFV c vs)        = CFV c (fmap (concat v1) vs)
     concat v1 res               = res
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cNonExist)              = NonExist
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cSOFT_SPACE)            = if null ws
                                               then Const (b,ws,q:qs)
                                               else Const (b,ws,qs)
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cBIND) || q == (cPredef,cSOFT_BIND) 
                                           = if null ws
                                               then Const (True,ws,q:qs)
                                               else Const (True,ws,qs)
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cCAPIT) = capit ws
   where
     capit []            = Const (b,[],q:qs)
     capit ((c:cs) : ws) = Const (b,(toUpper c : cs) : ws,qs)
     capit ws            = Const (b,ws,qs)
-value2string' g (VApp c q []) b   ws     qs
+value2string' g (VApp q [])   b   ws     qs
   | q == (cPredef,cALL_CAPIT) = all_capit ws
   where
     all_capit []       = Const (b,[],q:qs)
@@ -1154,7 +1244,7 @@ value2float g (VFlt f)         = Const f
 value2float g (VFV s vs)       = CFV s (fmap (value2float g) vs)
 value2float g _                = RunTime
 
-value2expr g xs (VApp _ (m,f) vs)
+value2expr g xs (VApp (m,f) vs)
   | m /= cPredef               = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EFun (showIdent f))) vs
 value2expr g xs (VMeta i vs)   = CSusp i (\v -> value2expr g xs (apply g v vs))
 value2expr g xs (VSusp i k vs) = CSusp i (\v -> value2expr g xs (apply g (k v) vs))
@@ -1174,9 +1264,6 @@ newtype Choice = Choice { unchoice :: Integer }
 unit :: Choice
 unit = Choice 1
 
-poison :: Choice
-poison = Choice (-1)
-
 split :: Choice -> (Choice,Choice)
 split (Choice c) = (Choice (2*c), Choice (2*c+1))
 

src/compiler/api/GF/Compile/Compute/Abstract.hs

@@ -1,138 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : GF.Compile.Abstract.Compute
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/02 20:50:19 $ 
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.8 $
---
--- computation in abstract syntax w.r.t. explicit definitions.
---
--- old GF computation; to be updated
------------------------------------------------------------------------------
-
-module GF.Compile.Compute.Abstract (LookDef,
-		   compute, 
-		   computeAbsTerm, 
-		   computeAbsTermIn, 
-		   beta
-		  ) where
-
-import GF.Data.Operations
-
-import GF.Grammar
-import GF.Grammar.Lookup
-
-import Debug.Trace
-import Data.List(intersperse)
-import Control.Monad (liftM, liftM2)
-import GF.Text.Pretty
-
--- for debugging
-tracd m t = t 
--- tracd = trace
-
-compute :: SourceGrammar -> Term -> Err Term
-compute = computeAbsTerm
-
-computeAbsTerm :: SourceGrammar -> Term -> Err Term
-computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
-
--- | a hack to make compute work on source grammar as well
-type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
-
-computeAbsTermIn :: LookDef -> [Ident] -> Term -> Err Term
-computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where
-  compt vv t = case t of
---    Prod x a b  -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
---    Abs x b     -> liftM  (Abs  x)              (compt (x:vv) b)
-    _ -> do
-      let t' = beta vv t
-      (yy,f,aa) <- termForm t'
-      let vv' = map snd yy ++ vv
-      aa'    <- mapM (compt vv') aa
-      case look f of
-        Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $ 
-                          case findMatch eqs aa' of
-          Ok (d,g) -> do
-            --- let (xs,ts) = unzip g
-            --- ts' <- alphaFreshAll vv' ts
-            let g' = g --- zip xs ts'
-            d' <- compt vv' $ substTerm vv' g' d
-            tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d'
-          _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ 
-               do
-            let v = mkApp f aa'
-            return $ mkAbs yy $ v
-        _ -> do
-          let t2 = mkAbs yy $ mkApp f aa'
-          tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2
-
-  look t = case t of
-     (Q (m,f)) -> case lookd m f of
-       Ok (_,md) -> md
-       _ -> Nothing
-     _ -> Nothing
-
-beta :: [Ident] -> Exp -> Exp
-beta vv c = case c of
-  Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) 
-  App f         a -> 
-    let (a',f') = (beta vv a, beta vv f) in 
-    case f' of
-      Abs _ x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) 
-      _ ->               (if a'==a && f'==f then id else beta vv) $ App f' a'
-  Prod b x a t      -> Prod b x (beta vv a) (beta (x:vv) t)
-  Abs b x t       -> Abs b x (beta (x:vv) t)
-  _               -> c
-
--- special version of pattern matching, to deal with comp under lambda
-
-findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
-findMatch cases terms = case cases of
-  [] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms)))
-  (patts,_):_ | length patts /= length terms -> 
-       Bad (render (text "wrong number of args for patterns :" <+> 
-                    hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
-  (patts,val):cc -> case mapM tryMatch (zip patts terms) of
-     Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs)
-     _         -> findMatch cc terms
-
-tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do 
-  t' <- termForm t
-  trym p t'
- where
-
-  trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- 
-              case (p,t') of
-    (PW,    _) | notMeta t -> return [] -- optimization with wildcard
-    (PV x,  _) | notMeta t -> return [(x,t)]
-    (PString s, ([],K i,[])) | s==i -> return []
-    (PInt s, ([],EInt i,[])) | s==i -> return []
-    (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
-    (PP (q,p) pp, ([], QC (r,f), tt)) | 
-       p `eqStrIdent` f && length pp == length tt -> do
-         matches <- mapM tryMatch (zip pp tt)
-         return (concat matches)
-    (PP (q,p) pp, ([], Q (r,f), tt)) | 
-       p `eqStrIdent` f && length pp == length tt -> do
-         matches <- mapM tryMatch (zip pp tt)
-         return (concat matches)
-    (PT _ p',_) -> trym p' t'
-    (PAs x p',_) -> do
-       subst <- trym p' t'
-       return $ (x,t) : subst
-    _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t))
-
-  notMeta e = case e of
-    Meta _  -> False
-    App f a -> notMeta f &&  notMeta a  
-    Abs _ _ b -> notMeta b
-    _ -> True
-
-  prtm p g = 
-    ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g])

src/compiler/api/GF/Compile/ConcreteToHaskell.hs

@@ -93,7 +93,7 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
       | s == cStr = tcon0 (identS "Str")
     convLinType (QC (_,p)) = tcon0 (gId p)
     convLinType (RecType lbls) = tcon (rcon' ls) (map convLinType ts)
-      where (ls,ts) = unzip $ sortOn fst lbls
+      where (ls,_,ts) = unzip3 $ sortOn (\(l,_,_)->l) lbls
     convLinType (Table pt lt) = Fun (convLinType pt) (convLinType lt)
 
     lincatDef c ty = tsyn0 (lincatName c) (convLinType ty)
@@ -170,8 +170,9 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
 
     convertPatt (PC c     ps) = ConP (gId c) (map convertPatt ps)
     convertPatt (PP (_,c) ps) = ConP (gId c) (map convertPatt ps)
-    convertPatt (PV v)        = VarP v
+    convertPatt (PV v)
-    convertPatt PW            = WildP
+      | v == identW           = WildP
+      | otherwise             = VarP v
     convertPatt (PR lbls)     = ConP (rcon' ls) (map convertPatt ps)
       where (ls,ps) = unzip $ sortOn fst lbls
     convertPatt (PString s)   = Lit s

src/compiler/api/GF/Compile/Export.hs

@@ -49,7 +49,6 @@ exportPGF opts fmt pgf =
       FmtSLF          -> single "slf"  slfPrinter
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
-      FmtLR           -> single "dot"  (\_ -> graphvizLRAutomaton)
  where
    name = fromMaybe (abstractName pgf) (flag optName opts)
 

src/compiler/api/GF/Compile/GenerateBC.hs

@@ -13,7 +13,7 @@ import Data.Maybe(fromMaybe)
 generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]]
 generateByteCode gr arity eqs =
   let (bs,instrs) = compileEquations gr arity (arity+1) is 
-                                     (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) 
+                                     (map (\(L _ (ps,t)) -> ([],ps,t)) eqs)
                                      Nothing
                                      [b]
       b = if arity == 0 || null eqs
@@ -50,8 +50,9 @@ compileEquations gr arity st (i:is) eqs       fl bs = whilePP eqs Map.empty
                                                              in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1)
 
     whilePV []                           vrs = compileEquations gr arity st is vrs fl bs
-    whilePV ((vs, PV x     : ps, t):eqs) vrs = whilePV eqs (((x,i):vs,ps,t) : vrs)
+    whilePV ((vs, PV x     : ps, t):eqs) vrs
-    whilePV ((vs, PW       : ps, t):eqs) vrs = whilePV eqs ((      vs,ps,t) : vrs)
+      | x == identW                          = whilePV eqs ((      vs,ps,t) : vrs)
+      | otherwise                            = whilePV eqs (((x,i):vs,ps,t) : vrs)
     whilePV ((vs, PTilde _ : ps, t):eqs) vrs = whilePV eqs ((      vs,ps,t) : vrs)
     whilePV ((vs, PImplArg p:ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
     whilePV ((vs, PT _ p   : ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs
@@ -101,11 +102,11 @@ compileFun gr eval st vs (App e1 e2) h0 bs args =
   let (h1,bs1,arg,is1) = compileArg gr st vs e2 h0 bs
       (h2,bs2,is2) = compileFun gr eval st vs e1 h1 bs1 (arg:args)
   in (h2,bs2,is1++is2)
-compileFun gr eval st vs (Q (m,id))  h0 bs args =
+compileFun gr eval st vs (Q q@(m,id))  h0 bs args =
-  case lookupAbsDef gr m id of
+  case lookupAbsDef gr q of
-    Ok (_,Just _)
+    Ok (Just _)
        -> (h0,bs,eval st (GLOBAL (showIdent id)) args)
-    _  -> let Ok ty = lookupFunType gr m id
+    _  -> let Ok ty = lookupFunType gr q
               (ctxt,_,_) = typeForm ty
               c_arity    = length ctxt
               n_args = length args
@@ -164,10 +165,10 @@ compileFun gr eval st vs e@(Glue e1 e2) h0 bs args =
   in (h1,bs1,[PUSH_ACCUM (LFlt 0)]++is++[POP_ACCUM]++eval (st+1) (ARG_VAR st) [])
 compileFun gr eval st vs e _ _ _ = error (show e)
 
-compileArg gr st vs (Q(m,id)) h0 bs =
+compileArg gr st vs (Q q@(m,id)) h0 bs =
-  case lookupAbsDef gr m id of
+  case lookupAbsDef gr q of
-    Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[])
+    Ok (Just _)   -> (h0,bs,GLOBAL (showIdent id),[])
-    _             -> let Ok ty = lookupFunType gr m id
+    _             -> let Ok ty = lookupFunType gr q
                          (ctxt,_,_) = typeForm ty
                          c_arity    = length ctxt
                      in if c_arity == 0
@@ -201,17 +202,9 @@ compileArg gr st vs (ImplArg e) h0 bs =
   compileArg gr st vs e h0 bs
 compileArg gr st vs e           h0 bs =
   let (f,es)   = appForm e
-      isConstr = case f of
+  in case f of
-                   Q c@(m,id) -> case lookupAbsDef gr m id of
+       QC q@(m,id) ->
-                                   Ok (_,Just _) -> Nothing
+            let Ok ty = lookupFunType gr q
-                                   _             -> Just c
-                   QC c@(m,id) -> case lookupAbsDef gr m id of
-                                    Ok (_,Just _) -> Nothing
-                                    _             -> Just c
-                   _        -> Nothing
-  in case isConstr of
-       Just (m,id) ->
-            let Ok ty = lookupFunType gr m id
                 (ctxt,_,_) = typeForm ty
                 c_arity    = length ctxt
                 ((h1,bs1,is1),args) = mapAccumL (\(h,bs,is) e -> let (h1,bs1,arg,is1) = compileArg gr st vs e h bs
@@ -234,7 +227,7 @@ compileArg gr st vs e           h0 bs =
                                 EVAL (HEAP h0) (TailCall diff) :
                                 []
                       in (h2,b:bs1,HEAP h1,is1 ++ (PUT_CLOSURE (length bs):is2))
-       Nothing -> compileLambda gr st vs [] e h0 bs
+       _ -> compileLambda gr st vs [] e h0 bs
 
 compileLambda gr st vs xs (Abs _ x e) h0 bs =
   compileLambda gr st vs (x:xs) e h0 bs

src/compiler/api/GF/Compile/GeneratePMCFG.hs

@@ -1,235 +1,331 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------
--- |
--- Maintainer  : Krasimir Angelov
--- Stability   : (stable)
--- Portability : (portable)
---
--- Convert PGF grammar to PMCFG grammar.
---
------------------------------------------------------------------------------
-
 module GF.Compile.GeneratePMCFG
     (generatePMCFG, pmcfgForm, type2fields
     ) where
 
-import GF.Grammar hiding (VApp,VRecType)
+import GF.Infra.Ident
-import GF.Grammar.Predef
-import GF.Grammar.Lookup
-import GF.Infra.CheckM
 import GF.Infra.Option
-import GF.Text.Pretty
+import GF.Infra.CheckM
-import GF.Compile.Compute.Concrete
+import GF.Data.Operations
-import GF.Data.Operations(Err(..))
+import GF.Grammar.Grammar
-import PGF2.Transactions
+import GF.Grammar.Lookup
-import Control.Monad
+import GF.Grammar.Macros
-import Control.Monad.State
+import GF.Grammar.Predef
-import Control.Monad.ST
+import GF.Grammar.Printer hiding (ppValue)
-import qualified Data.Map.Strict as Map
+import GF.Text.Pretty hiding (empty)
-import qualified Data.Sequence as Seq
+import GF.Compile.Compute hiding ( getMeta, setMeta, globals, variants )
-import Data.List(mapAccumL,sortOn,sortBy)
+import qualified GF.Text.Pretty as PP
-import Data.Maybe(fromMaybe,isNothing)
+import qualified Data.Map as Map
-import Data.STRef
+import qualified Data.Set as Set
+import Control.Applicative
+import Control.Monad (foldM,zipWithM,liftM,liftM2,forM,MonadPlus(..))
+import Control.Monad.Fix
+import Data.Maybe
+import Data.List(mapAccumL,sortBy,sortOn,intersperse)
+import Data.Containers.ListUtils(nubOrd)
+import Prelude hiding ((<>))
+
 
 generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
 generatePMCFG opts cwd gr cmo@(cm,cmi)
-  | mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) =
+  | mstatus cmi == MSComplete && isModCnc cmi =
                 do let gr' = prependModule gr cmo
-                   (js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty
+                       g   = Gl gr' (stdPredef g) False
-                   return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
+                   js <- Map.traverseWithKey (addPMCFG cwd g cmi) (jments cmi)
+                   return (cm,cmi{jments = js})
   | otherwise = return cmo
-  where
-    mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m)))
 
-type SequenceSet = Map.Map [Symbol] Int
+addPMCFG cwd g cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do
-
+  defs <- case mdef of
-addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the lindef of" <+> id) $ do
-  (defs,seqs) <-
+                                t <- mkLinDefault sgr ty
-          case mdef of
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
-                                   term <- mkLinDefault gr ty
+                                pmcfgForm g t [(Explicit,identW,Sort cStr)] ty
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+  refs <- case mref of
-            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+            Nothing        -> checkInModule cwd cmi loc ("Happened in the rule generation for the linref of" <+> id) $ do
-                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+                                t <- mkLinReference sgr ty
-  (refs,seqs) <- 
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
-          case mref of
+            Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
-            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr)
-                                   term <- mkLinReference gr ty
-                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
-            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
-                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
   mprn  <- case mprn of
              Nothing          -> return Nothing
              Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
-                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   prn <- normalForm g prn
                                    return (Just (L loc prn))
-  return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
+  return (CncCat mty mdef mref mprn (Just (defs,refs)))
-addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
+  where
-  (rules,seqs) <-
+    Gl sgr _ _ = g
-           checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
+addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc term)) mprn Nothing) = do
-             pmcfgForm gr term ctxt val seqs
+  rules <- checkInModule cwd cmi loc ("Happened in the rule generation for" <+> id) $
+             pmcfgForm g term ctxt ty
   mprn  <- case mprn of
              Nothing          -> return Nothing
              Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
-                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   prn <- normalForm g prn
                                    return (Just (L loc prn))
-  return (CncFun mty mlin mprn (Just rules),seqs)
+  return (CncFun (Just lty) mlin mprn (Just rules))
-addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
-
-pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
-pmcfgForm gr t ctxt ty seqs = do
-  res <- runEvalM (Gl gr stdPredef) $ do
-           (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
-                                          t <- EvalM (\(Gl gr _) k e mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
-                                                                                       k t mt d r msgs)
-                                          tnk <- newThunk [] t
-                                          return (arg_no+1,tnk))
-                                      0 ctxt
-           v <- eval [] t args
-           (lins,params) <- flatten v ty ([],[])
-           lins <- fmap reverse $ mapM str2lin lins
-           (r,rs,_) <- compute params
-           args <- zipWithM tnk2lparam args ctxt
-           vars <- getVariables
-           let res = LParam r (order rs)
-           return (vars,args,res,lins)
-  return (runState (mapM mkProduction res) seqs)
   where
-    tnk2lparam tnk (_,_,ty) = do
+    Gl sgr _ _ = g
-      v <- force tnk
-      (_,params) <- flatten v ty ([],[])
-      (r,rs,_) <- compute params
-      return (PArg [] (LParam r (order rs)))
 
-    compute []              = return (0,[],1)
+addPMCFG cwd g cmi id info = return info
-    compute ((v,ty):params) = do
-      (r, rs ,cnt ) <- param2int v ty
-      (r',rs',cnt') <- compute params
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
 
-    mkProduction (vars,args,res,lins) = do
+pmcfgForm g t ctxt ty = do
-      lins <- mapM getSeqId lins
+  let (c1,c2) = split unit
-      return (Production vars args res lins)
+      (ms,s',t',arg_params) = apply 0 Map.empty c1 ctxt t []
+      v = eval g [] s' t' []
+  (ms,_,_,fn) <- breakDown g ms c2 0 [] v ty (return []) empty
+  res <- fmap nubOrd $ runGenM g ms [] $ do
+            (r,rs,v,res_params) <- fn
+            (subst,arg_params) <- mapAccumM params2int Map.empty arg_params
+            (subst,res_params) <- params2int subst res_params
+            (subst,lin_idx)    <- params2int' subst r rs
+            (subst,seq)        <- flatten subst v
+            qs <- quantifiers (Map.toList subst)
+            return (Rule qs res_params arg_params lin_idx seq)
+  length res `seq` return res
+  where
+    Gl sgr _ _ = g
+
+    quantifiers vars = GenM (\(Gl sgr _ _) k svs ms ->
+      k [boundsOf sgr ms variable | (variable,v) <- sortOn snd vars]
+        svs ms)
       where
-        getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
+        boundsOf sgr ms i =
-        getSeqId lin = state $ \m ->
+          case Map.lookup i ms of
-          case Map.lookup lin m of
+            Just (Narrowing _ pty) -> case countParamValues sgr pty of
-            Just seqid -> (seqid,m)
+                                        Ok c    -> c
-            Nothing    -> let seqid = Map.size m
+                                        Bad msg -> error msg
-                          in (seqid,Map.insert lin seqid m)
+            _                      -> error (show (ppLVar i <+> "is not a free variable"))
 
-type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
+    apply d ms s []              t args = (ms,s,t,reverse args)
-type2metaTerm gr d ms r rs (Sort s) | s == cStr =
+    apply d ms s ((_,_,ty):ctxt) t args =
-  return (ms,r+1,TSymCat d r rs)
+       let (ms',s',_,t2,params) = type2metaTerm sgr d ms s 0 [] ty []
-type2metaTerm gr d ms r rs (RecType lbls) = do
+       in apply (d+1) ms' s' ctxt (App t t2) (params:args)
-  ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
+
-                                                        LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
+type2fields :: SourceGrammar -> Type -> [String]
-                                                        lbl    -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
+type2fields gr = type2fields PP.empty
-                                                                     return ((ms',r'),(lbl,(Just ty,t))))
-                                 (ms,r) lbls
-  return (ms',r',R ass)
-type2metaTerm gr d ms r rs (Table p q)
-  | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
-                    return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
-  | null (collectParams q)
-               = do let pv    = varX (length rs+1)
-                    (ms',delta,t) <-
-                        fixST $ \(~(_,delta,_)) ->
-                                     do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
-                                        return (ms',r'-r,t)
-                    return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
-  | otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q
-                                                               return ((ms',r'),t))
-                                              (ms,r) [0..count-1]
-                   return (ms',r+(r'-r),V p ts)
   where
-    collectParams (QC q)      = [q]
+    type2fields d (Sort s) | s == cStr = [show d]
-    collectParams (Table _ t) = collectParams t
+    type2fields d (RecType lbls) =
-    collectParams t           = collectOp collectParams t
+      concatMap (\(lbl,_,ty) -> type2fields (d <+> pp lbl) ty) lbls
+    type2fields d (Table p q) =
+      let Ok ts = allParamValues gr p
+      in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
+    type2fields d _ = []
 
-    count = case allParamValues gr p of
+
-              Ok ts   -> length ts
+mkLinDefault :: SourceGrammar -> Type -> Check Term
+mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
+ where
+   mkDefField ty =
+     case ty of
+       Table p t  -> do t' <- mkDefField t
+                        let T _ cs = mkWildCases t'
+                        return $ T (TWild p) cs
+       Sort s | s == cStr -> return (Vr varStr)
+       QC p       -> case allParamValues gr ty of
+                       Ok []    -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
+                       Ok (v:_) -> return v
+                       Bad msg  -> fail msg
+       RecType r -> do
+         let (ls,_,ts) = unzip3 r
+         ts <- mapM mkDefField ts
+         return $ R (zipWith assign ls ts)
+       _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
+       _ -> checkError ("a field in a linearization type cannot be" <+> ty)
+
+mkLinReference :: SourceGrammar -> Type -> Check Term
+mkLinReference gr typ = do
+  mb_term <- mkRefField typ (Vr varStr)
+  return (Abs Explicit varStr (fromMaybe Empty mb_term))
+  where
+    mkRefField ty trm =
+      case ty of
+        Table pty ty -> do ps <- allParamValues gr pty
+                           case ps of
+                             []     -> fail (render ("no parameter values given to type" <+> pty))
+                             (p:ps) -> mkRefField ty (S trm p)
+        Sort s | s == cStr -> return (Just trm)
+        QC p       -> return Nothing
+        RecType rs -> traverse rs trm
+        _ | Just _ <- isTypeInts ty -> return Nothing
+        _ -> fail (render ("a field in a linearization type cannot be" <+> typ))
+
+    traverse []            trm = return Nothing
+    traverse ((l,_,ty):rs) trm = do res <- mkRefField ty (P trm l)
+                                    case res of
+                                      Just trm -> return (Just trm)
+                                      Nothing  -> traverse rs trm
+
+
+type2metaTerm :: SourceGrammar -> Int -> MetaVars -> Choice -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> [(Value,Type)] -> (MetaVars,Choice,Int,Term,[(Value,Type)])
+type2metaTerm gr d ms s r rs (Sort srt)     params | srt == cStr = (ms,s,r+1,TSymCat d r rs,params)
+type2metaTerm gr d ms s r rs (RecType lbls) params =
+  let ((ms',s',r',params'),ass) =
+          mapAccumL (\(ms,s,r,params) (lbl,_,ty) -> case lbl of
+                                                      LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j)))
+                                                      lbl    -> let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs ty params
+                                                                in ((ms',s',r',params'),(lbl,(Just ty,t))))
+                    (ms,s,r,params) lbls
+  in (ms',s',r',R ass,params')
+type2metaTerm gr d ms s r rs (Table p q) params
+  | count == 1 = let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs q params
+                 in (ms',s',r+(r'-r),T (TTyped p) [(PV identW,t)],params')
+  | otherwise  = let pv     = varX (length rs+1)
+                     (ms',s',r',t,params') = type2metaTerm gr d ms s r ((delta,(pv,p)):rs) q params
+                     delta  = r'-r
+                 in (ms',s',r+delta*count,T (TTyped p) [(PV pv,t)],params')
+  where
+    count = case countParamValues gr p of
+              Ok c    -> c
               Bad msg -> error msg
-type2metaTerm gr d ms r rs ty@(QC q) = do
+type2metaTerm gr d ms c r rs ty@(QC q) params =
   let i = Map.size ms + 1
-  tnk <- newSTRef (Narrowing i ty)
+      (c1,c2) = split c
-  return (Map.insert i tnk ms,r,Meta i)
+  in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
-type2metaTerm gr d ms r rs ty
+type2metaTerm gr d ms c r rs ty params
-  | Just n <- isTypeInts ty = do
+  | Just n <- isTypeInts ty =
       let i = Map.size ms + 1
-      tnk <- newSTRef (Narrowing i ty)
+          (c1,c2) = split c
-      return (Map.insert i tnk ms,r,Meta i)
+      in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params)
 
-flatten (VR as) (RecType lbls) st = do
-  foldM collect st lbls
-  where
-    collect st (lbl,ty) =
-      case lookup lbl as of
-        Just tnk -> do v <- force tnk
-                       flatten v ty st
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
-flatten v@(VT _ env cs) (Table p q) st = do
-  ts <- getAllParamValues p
-  foldM collect st ts
-  where
-    collect st t = do
-      tnk <- newThunk [] t
-      let v0 = VS v tnk []
-      v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
-      flatten v q st
-flatten (VV _ tnks) (Table _ q) st = do
-  foldM collect st tnks
-  where
-    collect st tnk = do
-      v <- force tnk
-      flatten v q st
-flatten v (Sort s) (lins,params) | s == cStr = do
-  deepForce v
-  return (v:lins,params)
-flatten v ty@(QC q) (lins,params) = do
-  deepForce v
-  return (lins,(v,ty):params)
-flatten v ty (lins,params)
-  | Just n <- isTypeInts ty = do deepForce v
-                                 return (lins,(v,ty):params)
-  | otherwise               = evalError (pp (showValue v))
 
-deepForce (VR as)          = mapM_ (\(lbl,v) -> force v >>= deepForce) as
+breakDown g ms s r rs v (Sort sort)    fn0 fn
-deepForce (VApp q tnks)    = mapM_ (\tnk -> force tnk >>= deepForce) tnks
+  | sort == cStr                              =
-deepForce (VC v1 v2)       = deepForce v1 >> deepForce v2
+      let fn' = do params <- fn0
-deepForce (VAlts def alts) = do deepForce def
+                   v      <- force v
-                                mapM_ (\(v,_) -> deepForce v) alts
+                   return (r,rs,v,params)
-deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
+                <|>
-deepForce _                = return ()
+                do fn
-
+      in return (ms,r+1,fn0,fn')
-str2lin (VApp q [])
+breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn
-  | q == (cPredef, cBIND)       = return [SymBIND]
-  | q == (cPredef, cNonExist)   = return [SymNE]
-  | q == (cPredef, cSOFT_BIND)  = return [SymSOFT_BIND]
-  | q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
-  | q == (cPredef, cCAPIT)      = return [SymCAPIT]
-  | q == (cPredef, cALL_CAPIT)  = return [SymALL_CAPIT]
-str2lin (VStr s)         = return [SymKS s]
-str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
-                              return [SymCat d (LParam r (order rs))]
   where
-    compute r' []                     = return (r',[])
+    traverse ms r rs []                fn0 fn = return (ms,r,fn0,fn)
-    compute r' ((cnt',(tnk,ty)):tnks) = do
+    traverse ms r rs ((lbl,_,ty):lbls) fn0 fn = do (ms,r,fn0,fn) <- breakDown g ms s r rs (project v) ty fn0 fn
-      v <- force tnk
+                                                   traverse ms r rs lbls fn0 fn
-      (r, rs, cnt) <- param2int v ty
+      where
-      (r',rs') <- compute r' tnks
+        project (VR as)       = case lookup lbl as of
-      return (r*cnt'+r',combine cnt' rs rs')
+                                  Nothing -> error (render ("Missing value for label" <+> pp lbl $$
-str2lin (VSymVar d r)    = return [SymVar d r]
+                                                            "in" <+> ppValue Unqualified 0 (VR as)))
-str2lin VEmpty           = return []
+                                  Just v  -> v
-str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
+        project (VFV c fvs)   = VFV c (fmap project fvs)
-str2lin v0@(VAlts def alts)
+        project (VMeta i vs)  = VSusp i (\v -> project (apply g v vs)) []
-                         = do def <- str2lin def
+        project (VSusp i k vs)= VSusp i (\v -> project (apply g (k v) vs)) []
-                              alts <- forM alts $ \(v1,v2) -> do
+        project (VError msg)  = VError msg
-                                lin <- str2lin v1
+        project v             = VP v lbl []
-                                ss  <- to_strs v2
+breakDown g ms c r rs v (Table p q) fn0 fn = do
-                                return (lin,ss)
+  let i  = Map.size ms + 1
-                              return [SymKP def alts]
+      v2 = VMeta i []
+      v0 = VS v v2 []
+      (c1,c2) = split c
+      Gl gr _ _ = g
+  cnt <- countParamValues gr p
+  (ms,r',fn0,fn) <- mfix $ \(~(_,r',_,_)) ->
+       breakDown g (Map.insert i (Narrowing c1 p) ms) c2 r ((r'-r,(v2,p)):rs) (select v0 v v2) q fn0 fn
+  return (ms,r+(r'-r)*cnt,fn0,fn)
+  where
+    select v0 (VT _  env s cs) v2 = patternMatch g s v0 (map (\(p,t) -> (env,[p],[v2],t)) cs)
+    select v0 (VV vty tvs)     v2 = vtableSelect g v0 vty tvs v2 []
+    select v0 (VFV i fvs)      v2 = VFV i (fmap (\v1 -> select v0 v1 v2) fvs)
+    select v0 (VMeta i vs)     v2 = VSusp i (\v -> select v0 (apply g v vs) v2) []
+    select v0 (VSusp i k vs)   v2 = VSusp i (\v -> select v0 (apply g (k v) vs) v2) []
+    select v0 (VError msg)     v2 = VError msg
+    select v0 v1               v2 = v0
+breakDown g ms s r rs v ty@(QC q) fn0 fn =
+  let fn0' = do params <- fn0
+                v <- force v
+                return ((v,ty):params)
+      fn'  = do (r,rs,v',res_params) <- fn
+                v <- force v
+                return (r,rs,v',(v,ty):res_params)
+  in return (ms,r,fn0',fn')
+breakDown g ms s r rs v ty@(App (Q q) _) fn0 fn =
+  let fn0' = do params <- fn0
+                v <- force v
+                return ((v,ty):params)
+      fn'  = do (r,rs,v',res_params) <- fn
+                v <- force v
+                return (r,rs,v',(v,ty):res_params)
+  in return (ms,r,fn0',fn')
+
+force (VStr s) = return (VStr s)
+force (VInt n) = return (VInt n)
+force (VFlt d) = return (VFlt d)
+force (VSymCat d r rs) = do
+  rs <- mapM force_ rs
+  return (VSymCat d r rs)
+  where
+    force_ (factor, (v, ty)) = do
+      v <- force v
+      return (factor, (v, ty))
+force (VSymVar d j) = return (VSymVar d j)
+force (VApp q vs) = do
+  vs <- mapM force vs
+  return (VApp q vs)
+force (VAlts def alts) = do
+  def  <- force def
+  alts <- mapM force_ alts
+  return (VAlts def alts)
+  where
+    force_ (x,y) = do
+      x <- force x
+      y <- force y
+      return (x,y)
+force VEmpty     = return VEmpty
+force (VC v1 v2) = do
+  v1 <- force v1
+  v2 <- force v2
+  return (VC v1 v2)
+force (VMeta i vs) = do
+  vs <- mapM force vs
+  return (VMeta i vs)
+force (VSusp i k vs) = do
+  vs <- mapM force vs
+  st <- getMeta i
+  v <- case st of
+         Narrowing c ty -> do v <- chooseMetaValue c ty
+                              setMeta i (Bound undefined v)
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  force (apply g (k v) vs)
+force (VStrs vs) = do
+  vs <- mapM force vs
+  return (VStrs vs)
+force (VR as) = do
+  as <- mapM (\(l,v) -> fmap ((,) l) (force v)) as
+  return (VR as)
+force v@(VPatt _ _ _) = return v
+force (VFV c vs) = do
+  v <- variants c (unvariants vs)
+  force v
+force (VError msg) = compileError msg
+force v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v)
+
+
+flatten subst (VStr s) = return (subst,[SymKS s])
+flatten subst (VSymCat d r rs) = do
+  (subst,lin_index) <- params2int' subst r rs
+  return (subst,[SymCat d lin_index])
+flatten subst (VSymVar d j) = do
+  return (subst,[SymVar d j])
+flatten subst (VApp (m,id) [])
+  | m == cPredef && id == cBIND       = return (subst,[SymBIND])
+  | m == cPredef && id == cSOFT_BIND  = return (subst,[SymSOFT_BIND])
+  | m == cPredef && id == cSOFT_SPACE = return (subst,[SymSOFT_SPACE])
+  | m == cPredef && id == cNonExist   = return (subst,[SymNE])
+  | m == cPredef && id == cCAPIT      = return (subst,[SymCAPIT])
+  | m == cPredef && id == cALL_CAPIT  = return (subst,[SymALL_CAPIT])
+flatten subst v0@(VAlts def alts) = do
+  (subst,def) <- flatten subst def
+  (subst,alts) <- mapAccumM (\subst (alt,ps) -> do
+                                (subst,alt) <- flatten subst alt
+                                ps  <- to_strs ps
+                                return (subst,(alt,ps)))
+                            subst
+                            alts
+  return (subst,[SymKP def alts])
   where
     to_strs (VStrs vs)    = mapM to_str vs
     to_strs (VPatt _ _ p) = from_patt p
@@ -244,50 +340,94 @@ str2lin v0@(VAlts def alts)
     from_patt (PChars cs)  = return (map (:[]) cs)
     from_patt _            = fail
 
-    fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
+    fail = compileError ("Complex patterns are not supported in:" $$ nest 2 (ppValue Unqualified 0 v0))
-str2lin v                = do t <- value2term False [] v
+flatten subst VEmpty     = return (subst,[])
-                              evalError ("the string:" <+> ppTerm Unqualified 0 t $$
+flatten subst (VC v1 v2) = do
-                                         "cannot be evaluated at compile time.")
+  (subst,s1) <- flatten subst v1
+  (subst,s2) <- flatten subst v2
+  return (subst,s1++s2)
+flatten subst (VSusp i k vs) = do
+  st <- getMeta i
+  v <- case st of
+         Narrowing c ty -> do v <- chooseMetaValue c ty
+                              setMeta i (Bound undefined v)
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  flatten subst (apply g (k v) vs)
+flatten subst (VFV c vs) = do
+  v <- variants c (unvariants vs)
+  flatten subst v
+flatten subst (VError msg) = compileError msg
+flatten subst v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v  <+> "to a string")
 
-param2int (VR as) (RecType lbls) = compute lbls
+
+params2int subst rs = do
+  (subst,r,rs,_) <- compute subst rs
+  return (subst,LParam r (order rs))
   where
-    compute []              = return (0,[],1)
+    compute subst []              = return (subst,0,[],1)
-    compute ((lbl,ty):lbls) = do
+    compute subst ((v,ty):params) = do
+      (subst, r, rs, cnt ) <- param2int subst v ty
+      (subst, r',rs',cnt') <- compute subst params
+      return (subst, r*cnt'+r',combine cnt' rs rs',cnt*cnt')
+
+params2int' subst r0 rs = do
+  (subst,r,rs) <- compute subst rs
+  return (subst,LParam (r0+r) (order rs))
+  where
+    compute subst []                     = return (subst,0,[])
+    compute subst ((cnt',(v,ty)):params) = do
+      (subst, r, rs, cnt) <- param2int subst v ty
+      (subst, r',rs')     <- compute subst params
+      return (subst,r*cnt'+r',combine cnt' rs rs')
+
+param2int subst (VR as) (RecType lbls) = compute subst lbls
+  where
+    compute subst []                = return (subst,0,[],1)
+    compute subst ((lbl,_,ty):lbls) = do
       case lookup lbl as of
-        Just tnk -> do v <- force tnk
+        Just v   -> do (subst, r, rs ,cnt ) <- param2int subst v ty
-                       (r, rs ,cnt ) <- param2int v ty
+                       (subst, r',rs',cnt') <- compute subst lbls
-                       (r',rs',cnt') <- compute lbls
+                       return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+        Nothing  -> compileError ("Missing value for label" <+> pp lbl $$
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                                  "among" <+> hsep (punctuate (pp ',') (map fst as)))
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
+param2int subst (VApp q vs) ty = do
-param2int (VApp q tnks) ty = do
+  (      r ,    ctxt,cnt ) <- getIdxCnt q
-  (r ,    ctxt,cnt ) <- getIdxCnt q
+  (subst,r',rs',     cnt') <- compute subst ctxt vs
-  (r',rs',     cnt') <- compute ctxt tnks
+  return (subst,r+r',rs',cnt)
-  return (r+r',rs',cnt)
   where
-    getIdxCnt q = do
+    compute subst []              []     = return (subst,0,[],1)
-      (_,ResValue (L _ ty) idx) <- getInfo q
+    compute subst ((_,_,ty):ctxt) (v:vs) = do
-      let (ctxt,QC p) = typeFormCnc ty
+      (subst, r, rs ,cnt ) <- param2int subst v ty
-      (_,ResParam _ (Just (_,cnt))) <- getInfo p
+      (subst, r',rs',cnt') <- compute subst ctxt vs
-      return (idx,ctxt,cnt)
+      return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
-
+param2int subst (VInt n) ty
-    compute []              []         = return (0,[],1)
+  | Just max <- isTypeInts ty= return (subst,fromIntegral n,[],fromIntegral max+1)
-    compute ((_,_,ty):ctxt) (tnk:tnks) = do
+param2int subst (VMeta i _) ty = do
-      v <- force tnk
+  st <- getMeta i
-      (r, rs ,cnt ) <- param2int v ty
+  case st of
-      (r',rs',cnt') <- compute ctxt tnks
+    Narrowing c ty -> do count <- getCnt ty
-      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+                         case Map.lookup i subst of
-param2int (VInt n)        ty
+                           Just v  -> return (subst,0,[(1,v)],count)
-  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
+                           Nothing -> let v      = Map.size subst
-param2int (VMeta tnk _) ty = do
+                                          subst' = Map.insert i v subst
-  tnk_st <- getRef tnk
+                                      in return (subst',0,[(1,v)],count)
-  case tnk_st of
+    Bound _ v      -> param2int subst v ty
-    Evaluated _ v  -> param2int v ty
+param2int subst (VSusp i k vs) ty = do
-    Narrowing j ty -> do ts <- getAllParamValues ty
+  st <- getMeta i
-                         return (0,[(1,j-1)],length ts)
+  v <- case st of
-param2int v ty = do t <- value2term True [] v
+         Narrowing c ty -> do v <- chooseMetaValue c ty
-                    evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
+                              setMeta i (Bound undefined v)
-                               "cannot be evaluated at compile time.")
+                              return v
+         Bound _ v      -> return v
+  g <- globals
+  param2int subst (apply g (k v) vs) ty
+param2int subst (VFV c vs) ty = do
+  v <- variants c (unvariants vs)
+  param2int subst v ty
+param2int subst v ty = compileError ("the parameter:" <+> ppValue Unqualified 0 v $$
+                                     "cannot be evaluated at compile time.")
 
 combine' 1   rs 1    rs' = []
 combine' 1   rs cnt' rs' = rs'
@@ -302,63 +442,101 @@ combine cnt' ((r,pv):rs) ((r',pv'):rs') =
     EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
     GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
 
+
+type ChoiceMap = Map.Map Choice Int
+type MetaVars = Map.Map Int MetaState
+
+newtype GenM a = GenM {unGen :: forall r . Globals -> (a -> ChoiceMap -> MetaVars -> r -> Check r) -> ChoiceMap -> MetaVars -> r -> Check r}
+
+instance Functor GenM where
+  fmap f (GenM m) = GenM (\g k -> m g (k . f))
+
+instance Applicative GenM where
+  pure x = GenM (\g k -> k x)
+  (GenM f) <*> (GenM h) = GenM (\g k -> f g (\fn -> h g (\x -> k (fn x))))
+
+instance Alternative GenM where
+  empty = GenM (\g k svs ms r -> pure r)
+  (GenM f) <|> (GenM h) = GenM (\g k svs ms r -> f g k svs ms r >>= h g k svs ms)
+
+instance Monad GenM where
+  (GenM f) >>= h = GenM (\g k -> f g (\x -> case h x of {GenM h -> h g k}))
+
+instance MonadFail GenM where
+  fail msg = GenM (\_ _ _ _ _ -> fail msg)
+
+runGenM g ms r (GenM f) = f g (\x svs ms xs -> pure (x:xs)) Map.empty ms r
+
+compileError d = GenM (\_ _ _ _ _ -> checkError d)
+
+globals = GenM $ \g k -> k g
+
+variants :: Choice -> [a] -> GenM a
+variants c xs = GenM (\g k svs ms r ->
+                          case Map.lookup c svs of
+                            Just j  -> k (xs !! j) svs ms r
+                            Nothing -> foldM (\r (j,x) -> k x (Map.insert c j svs) ms r) r (zip [0..] xs))
+
+newMeta c ty = GenM $ \_ k svs ms ->
+  let i = Map.size ms + 1
+  in k i svs (Map.insert i (Narrowing c ty) ms)
+
+getMeta i = GenM $ \_ k svs ms r ->
+  case Map.lookup i ms of
+    Just v  -> k v svs ms r
+    Nothing -> checkError (pp "Meta variable" <+> ppMeta i <+> "is not defined")
+
+setMeta i st = GenM $ \_ k svs ms ->
+  k () svs (Map.insert i st ms)
+
+getCnt ty = GenM $ \(Gl gr _ _) k svs ms r ->
+  case countParamValues gr ty of
+    Ok c    -> k c svs ms r
+    Bad msg -> checkError (pp msg)
+
+getIdxCnt q = GenM $ \(Gl gr _ _) k svs ms r ->
+  case lookupOrigInfo gr q of
+    Ok (_,ResValue (L _ ty) idx) -> 
+      let (ctxt,QC p) = typeFormCnc ty
+      in case lookupOrigInfo gr p of
+           Ok (_,ResParam _ (Just (_,cnt))) -> k (idx,ctxt,cnt) svs ms r
+           Bad msg -> checkError (pp msg)
+    Bad msg -> checkError (pp msg)
+
+chooseMetaValue :: Choice -> Type -> GenM Value
+chooseMetaValue s ptyp = GenM $ \g@(Gl gr _ _) k svs ms r ->
+  case ptyp of
+    _ | Just n <- isTypeInts ptyp -> foldM (\r i -> k (VInt i) svs ms r) r [0..n]
+    QC c -> do (mod,info) <- lookupOrigInfo gr c
+               case info of
+                 ResParam (Just ps) _ -> mkValue mod k svs ms r 0 (unLoc ps)
+                 _                    -> checkError (ppQIdent Qualified c <+> "has no parameter values defined")
+    Q  c -> lookupResDef gr c >>= \ty -> unGen (chooseMetaValue s ty) g k svs ms r
+    RecType lbls -> unGen (mapAccumM mkField s lbls >>= \(_,lbls) -> return (VR lbls)) g k svs ms r
+    _ -> checkError ("cannot find parameter values for" <+> ptyp)
+  where
+    mkValue mod k svs ms r idx []             = return r
+    mkValue mod k svs ms r idx ((id,ctxt):ps) = do
+      let (ms',args) = mkVars ms s ctxt
+      r <- k (VApp (mod,id) args) (Map.insert s idx svs) ms' r
+      mkValue mod k svs ms r (idx+1) ps
+
+    mkVars ms c []              = (ms,[])
+    mkVars ms c ((_,_,ty):ctxt) =
+      let i = Map.size ms + 1
+          (c1,c2) = split c
+          (ms',args) = mkVars (Map.insert i (Narrowing c1 ty) ms) c2 ctxt
+      in (ms',VMeta i []:args)
+
+    mkField c (l,_,ty) = do
+       let (c1,c2) = split c
+       v <- chooseMetaValue c1 ty
+       return (c2,(l,v))
+
+order :: Ord a => [(a,b)] -> [(a,b)]
 order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
 
 mapAccumM f a []     = return (a,[])
 mapAccumM f a (x:xs) = do (a, y) <- f a x
                           (a,ys) <- mapAccumM f a xs
                           return (a,y:ys)
-
-type2fields :: SourceGrammar -> Type -> [String]
-type2fields gr = type2fields empty
-  where
-    type2fields d (Sort s) | s == cStr = [show d]
-    type2fields d (RecType lbls) =
-      concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) lbls
-    type2fields d (Table p q) =
-      let Ok ts = allParamValues gr p
-      in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
-    type2fields d _ = []
-
-mkLinDefault :: SourceGrammar -> Type -> Check Term
-mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
- where
-   mkDefField ty =
-     case ty of
-       Table p t  -> do t' <- mkDefField t
-                        let T _ cs = mkWildCases t'
-                        return $ T (TWild p) cs
-       Sort s | s == cStr -> return (Vr varStr)
-       QC p       -> case lookupParamValues gr p of
-                       Ok []    -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
-                       Ok (v:_) -> return v
-                       Bad msg  -> fail msg
-       RecType r -> do
-         let (ls,ts) = unzip r
-         ts <- mapM mkDefField ts
-         return $ R (zipWith assign ls ts)
-       _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
-       _ -> checkError ("a field in a linearization type cannot be" <+> ty)
-
-mkLinReference :: SourceGrammar -> Type -> Check Term
-mkLinReference gr typ = do
-  mb_term <- mkRefField typ (Vr varStr)
-  return (Abs Explicit varStr (fromMaybe Empty mb_term))
-  where
-    mkRefField ty trm =
-      case ty of
-        Table pty ty -> case allParamValues gr pty of
-                          Ok []     -> checkError ("no parameter values given to type" <+> pty)
-                          Ok (p:ps) -> mkRefField ty (S trm p)
-                          Bad msg   -> fail msg
-        Sort s | s == cStr -> return (Just trm)
-        QC p       -> return Nothing
-        RecType rs -> traverse rs trm
-        _ | Just _ <- isTypeInts ty -> return Nothing
-        _ -> checkError ("a field in a linearization type cannot be" <+> typ)
-
-    traverse []          trm = return Nothing
-    traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
-                                  case res of
-                                    Just trm -> return (Just trm)
-                                    Nothing  -> traverse rs trm

src/compiler/api/GF/Compile/GrammarToCanonical.hs

@@ -9,7 +9,7 @@ import GF.Grammar
 import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
 import GF.Infra.Option(Options,noOptions)
 import GF.Infra.CheckM
-import GF.Compile.Compute.Concrete2
+import GF.Compile.Compute
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Maybe(mapMaybe,fromMaybe)
@@ -36,7 +36,6 @@ abstract2canonical absname gr = do
                      mopens  = [],
                      mexdeps = [],
                      msrc    = "",
-                     mseqs   = Nothing,
                      jments  = Map.fromList infos
                    })
 
@@ -74,7 +73,6 @@ concretes2canonical opts absname gr = do
         mopens  = [],
         mexdeps = [],
         msrc    = "",
-        mseqs   = Nothing,
         jments  = Map.empty
       }
 
@@ -83,7 +81,7 @@ type QSet = Set.Set (ModuleName,Ident)
 -- | Generate Canonical GF for the given concrete module.
 concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check (QSet,Module)
 concrete2canonical gr absname cncname modinfo = do
-  let g = Gl gr (stdPredef g)
+  let g = Gl gr (stdPredef g) False
   infos <- mapM (convInfo g) (allOrigInfos gr cncname)
   let pts = Set.unions (map fst infos)
   return (pts,
@@ -96,17 +94,16 @@ concrete2canonical gr absname cncname modinfo = do
                       mopens  = [],
                       mexdeps = [],
                       msrc    = "",
-                      mseqs   = Nothing,
                       jments  = Map.fromList (mapMaybe snd infos)
                     }))
   where
-    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
+    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mpmcfg) = do
       typ <- normalForm g typ
       let pts = paramTypes typ
-      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
+      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mpmcfg))
-    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
+    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mpmcfg) = do
       def <- normalForm g (eta_expand def ctx)
-      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
+      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mpmcfg))
     convInfo g  _ = return (Set.empty,Nothing)
 
     eta_expand t []                   = t
@@ -114,7 +111,7 @@ concrete2canonical gr absname cncname modinfo = do
     eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x))           ctx)
 
 
-paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
+paramTypes (RecType fs) = Set.unions (map (\(_,_,t)->paramTypes t) fs)
 paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
 paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
 paramTypes (Sort _) = Set.empty

src/compiler/api/GF/Compile/GrammarToPGF.hs

@@ -57,18 +57,17 @@ grammar2PGF opts mb_pgf gr am probs = do
       createConcrete (mi2i cm) $ do
         let cflags = err (const noOptions) mflags (lookupModule gr cm)
         sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
-        let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]]
+        let infos = ( let z       = LParam 0 []
-                    , let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
+                          id_rule = Rule [] z [z] z [SymCat 0 z]
-                          prods   = ([id_prod],[id_prod])
+                          rules   = ([id_rule],[id_rule])
-                      in [(cInt,   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                      in [((cm,cInt),   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
-                         ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,((cm,cString),CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
-                         ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,((cm,cFloat), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules))
                          ]
                     )
-                    : prepareSeqTbls (Look.allOrigInfos gr cm)
+                    ++ Look.allOrigInfos gr cm
-        infos <- processInfos createCncCats infos
+        mapM_ createCncCats infos
-        infos <- processInfos createCncFuns infos
+        mapM_ createCncFuns infos
-        return ()
   return pgf
   where
     aflags = err (const noOptions) mflags (lookupModule gr am)
@@ -83,13 +82,13 @@ grammar2PGF opts mb_pgf gr am probs = do
                                ((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,
+                               ((m,f),AbsFun (Just (L _ ty)) mdef) <- adefs,
-                               let arity = mkArity ma mdef ty,
+                               let arity = mkArity mdef ty,
-                               let bcode = mkDef gr arity mdef,
+                               let bcode = mkDef gr mdef,
                                let f' = i2i f]
                                
     funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
-                    [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
+                    [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _) <- adefs,
                                                                let (_,(_,cat),_) = GM.typeForm ty,
                                                                let f' = i2i f]
       where
@@ -100,38 +99,19 @@ grammar2PGF opts mb_pgf gr am probs = do
                       0 -> 0
                       n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
 
-    prepareSeqTbls infos = 
+    createCncCats ((_,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
-       (map addSeqTable . Map.toList . Map.fromListWith (++))
+      createLincat (i2i c) (type2fields gr ty) lindefs linrefs
-               [(m,[(c,info)]) | ((m,c),info) <- infos]
-       where
-         addSeqTable (m,infos) = 
-           case lookupModule gr m of
-             Ok mi   -> case mseqs mi of
-                          Just seqs -> (fmap Left seqs,infos)
-                          Nothing   -> (Seq.empty,[])
-             Bad msg -> error msg
-
-    processInfos f []                    = return []
-    processInfos f ((seqtbl,infos):rest) = do
-      seqtbl <- foldM f seqtbl infos
-      rest <- processInfos f rest
-      return ((seqtbl,infos):rest)
-
-    createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
-      seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
-      return seqtbl
+    createCncCats _ = return ()
-    createCncCats seqtbl _ = return seqtbl
 
-    createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
+    createCncFuns ((_,f),CncFun _ _ mprn (Just rules)) = do
-      seqtbl <- createLin (i2i f) prods seqtbl
+      createLin (i2i f) rules
       case mprn of
         Nothing        -> return ()
         Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
-      return seqtbl
+    createCncFuns _ = return ()
-    createCncFuns seqtbl _ = return seqtbl
 
     term2tokens (K tok)     = [tok]
     term2tokens (C t1 t2)   = term2tokens t1 ++ term2tokens t2
@@ -173,7 +153,6 @@ mkPatt scope p =
     A.PV x      -> (x:scope,C.PVar (i2i x))
     A.PAs x p   -> let (scope',p') = mkPatt scope p
                    in (x:scope',C.PAs (i2i x) p')
-    A.PW        -> (  scope,C.PWild)
     A.PInt i    -> (  scope,C.PLit (C.LInt (fromIntegral i)))
     A.PFloat f  -> (  scope,C.PLit (C.LFlt f))
     A.PString s -> (  scope,C.PLit (C.LStr s))
@@ -188,13 +167,12 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
                                                            then (  scope,(bt,i2i x,ty'))
                                                            else (x:scope,(bt,i2i x,ty'))) scope hyps 
 
-mkDef gr arity (Just eqs) = generateByteCode gr arity eqs
+mkDef gr (Just (arity,eqs)) = generateByteCode gr arity eqs
-mkDef gr arity Nothing    = []
+mkDef gr Nothing    = []
 
-mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
+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
-mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
+                          in length ctxt
-                               in length ctxt
 {-
 genCncCats gr am cm cdefs = mkCncCats 0 cdefs
   where
@@ -408,14 +386,6 @@ compareCaseInsensitive (x:xs) (y:ys) =
                       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

src/compiler/api/GF/Compile/PGFtoHaskell.hs

@@ -50,7 +50,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 = ["import PGF2", ""]

src/compiler/api/GF/Compile/Rename.hs

@@ -30,7 +30,6 @@ module GF.Compile.Rename (
 import GF.Infra.Ident
 import GF.Infra.CheckM
 import GF.Grammar.Grammar
-import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Grammar.Lookup
 import GF.Grammar.Macros
@@ -87,7 +86,7 @@ renameIdentTerm' env@(act,imps) t0 =
 
     -- this facility is mainly for BWC with GF1: you need not import PredefAbs
     predefAbs c s
-      | isPredefCat c = return (Q (cPredefAbs,c))
+      | isPredefCat c = return (QC (cPredefAbs,c))
       | otherwise     = checkError s
 
     ident alt c =
@@ -106,7 +105,8 @@ renameIdentTerm' env@(act,imps) t0 =
 
 info2status :: Maybe ModuleName -> Ident -> Info -> Term
 info2status mq c i = case i of
-  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq c
+  AbsCat _ -> maybe Con (curry QC) mq c
+  AbsFun _ Nothing -> maybe Con (curry QC) mq c
   ResValue _ _ -> maybe Con (curry QC) mq c
   ResParam _ _ -> maybe Con (curry QC) mq c
   AnyInd True m -> maybe Con (const (curry QC m)) mq c
@@ -159,7 +159,7 @@ renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
 renameInfo cwd status (m,mi) i info =
   case info of
     AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
-    AbsFun  pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
+    AbsFun  pty ptr -> liftM2 AbsFun (renTerm pty) (renMaybe (\(a,eqs) -> fmap ((,) a) (mapM (renLoc (renEquation status)) eqs)) ptr)
     ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
     ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
     ResParam (Just pp) m -> do
@@ -218,6 +218,13 @@ renameTerm env vars = ren vars where
         _ -> return i
       liftM (T i') $ mapM (renCase vs) cs
 
+    RecType rs -> do
+      rs <- forM rs $ \(l,deps,t) -> do
+              t <- renameTerm env (deps++vs) t
+              let deps' = L.intersect deps (freeVars vs t)
+              return (l,deps',t)
+      return (RecType rs)
+
     Let (x,(m,a)) b -> do
       m' <- case m of
         Just ty -> liftM Just $ ren vs ty
@@ -255,6 +262,11 @@ renameTerm env vars = ren vars where
     return (p',t')
   renpatt = renamePattern env
 
+  freeVars xs (Abs _ x e) = freeVars (x:xs) e
+  freeVars xs (Vr x)
+    | not (elem x xs)     = [x]
+  freeVars xs e           = collectOp (freeVars xs) e
+
 -- | vars not needed in env, since patterns always overshadow old vars
 renamePattern :: Status -> Patt -> Check (Patt,[Ident])
 renamePattern env patt =
@@ -293,7 +305,8 @@ renamePattern env patt =
                 _      -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt)
         return (PM c', [])
 
-      PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of
+      PV x | x /= identW
+           -> checks [ renid' (Vr x) >>= \t' -> case t' of
                                                  QC c -> return (PP c [],[])
                                                  _    -> checkError (pp "not a constructor")
                      , return (patt, [x])
@@ -327,6 +340,10 @@ renamePattern env patt =
         (p',vs) <- renp p
         return (PAs x p', x:vs)
 
+      PImplArg p -> do
+        (p,vs) <- renp p
+        return (PImplArg p, vs)
+
       _ -> return (patt,[])
 
     renid = renameIdentTerm env

src/compiler/api/GF/Compile/SubExOpt.hs

@@ -31,6 +31,7 @@ import qualified GF.Grammar.Macros as C
 import GF.Data.ErrM(fromErr)
 
 import Control.Monad.State.Strict(State,evalState,get,put)
+import Data.Maybe(isJust)
 import Data.Map (Map)
 import qualified Data.Map as Map
 
@@ -136,6 +137,6 @@ operIdent :: Int -> Ident
 operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) ---
 
 isOperIdent :: Ident -> Bool
-isOperIdent id = isPrefixOf operPrefix (ident2raw id)
+isOperIdent id = isJust (isPrefixOf operPrefix (ident2raw id))
 
 operPrefix = rawIdentS ("A''")

src/compiler/api/GF/Compile/Tags.hs

@@ -28,8 +28,8 @@ getLocalTags x (m,mi) =
   where
     getLocations :: Info -> [(String,String,String)]
     getLocations (AbsCat mb_ctxt)               = maybe (loc "cat")          mb_ctxt
-    getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
+    getLocations (AbsFun mb_type mb_eqs)        = maybe (ltype "fun")        mb_type ++
-                                                  maybe (list (loc "def"))   mb_eqs  
+                                                  maybe (list (loc "def") . snd) mb_eqs  
     getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
     getLocations (ResValue mb_type _)           = ltype "param-value"          mb_type
     getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++

src/compiler/api/GF/Compile/TerminationCheck.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE BangPatterns #-}
+module GF.Compile.TerminationCheck where
+
+import GF.Grammar
+import Debug.Trace
+
+callGraph m c (ps,t) =
+  let (_,xs) = foldl (\(i,xs) p -> (i+1,patts i EQ xs p)) (0,[]) ps
+      cs     = calls m 0 xs t [] []
+  in trace (show (c,cs)) $ return ()
+
+patts i ord xs (PP _ ps)    = foldl (patts i LT) xs ps
+patts i ord xs (PV x)
+  | x /= identW             = (x,(i,ord)):xs
+patts i ord xs (PR as)      = foldl (\xs (_,p) -> patts i ord xs p) xs as
+patts i ord xs (PT ty p)    = patts i ord xs p
+patts i ord xs (PAs x p)    = patts i ord ((x,(i,ord)):xs) p
+patts i ord xs (PImplArg p) = patts i ord xs p
+patts i ord xs (PSeq _ _ p1 _ _ p2) = patts i LT (patts i LT xs p1) p2
+patts i ord xs _            = xs
+
+
+calls m i xs (App t1 t2) args cs =
+  let args' = case t2 of
+                Vr x -> case lookup x xs of
+                          Just (j,ord) -> (i,j,ord):args
+                          Nothing -> args
+                _    -> args
+  in calls m (i+1) xs t1 args' (calls m 0 xs t2 [] cs)
+calls m i xs (Q (m',q)) args cs
+  | m == m' =
+      let args' = [(i-i'-1,j,ord) | (i',j,ord) <- args]
+      in (q,args') : cs
+calls m i xs _ args cs = cs
+
+
+matmul a b =
+  sum [(i,k,mul ord1 ord2) | (i ,j,ord1) <- a
+                           , (j',k,ord2) <- b
+                           , j==j'
+                           ]
+      []
+  where
+    sum []                 ys = ys
+    sum (x@(i,k,ord) : xs) ys = sum xs (accumulate ys)
+      where
+        accumulate []      = [x]
+        accumulate (y@(i',k',ord') : ys)
+          | i==i' && k==k' = let !sum = add ord ord'
+                             in (i',k',sum):ys
+          | otherwise      = y : accumulate ys
+
+    add LT LT = LT
+    add LT EQ = LT
+    add LT GT = LT
+    add EQ LT = LT
+    add EQ EQ = EQ
+    add EQ GT = EQ
+    add GT LT = LT
+    add GT EQ = EQ
+    add GT GT = GT
+
+    mul LT LT = LT
+    mul LT EQ = LT
+    mul LT GT = GT
+    mul EQ LT = LT
+    mul EQ EQ = EQ
+    mul EQ GT = GT
+    mul GT LT = GT
+    mul GT EQ = GT
+    mul GT GT = GT

src/compiler/api/GF/Compile/TypeCheck/Abstract.hs

@@ -1,82 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : TypeCheck
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/15 16:22:02 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.16 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
-    checkContext,
-    checkTyp,
-    checkDef,
-    checkConstrs,
-   ) where
-
-import GF.Data.Operations
-
-import GF.Infra.CheckM
-import GF.Grammar
-import GF.Grammar.Lookup
-import GF.Grammar.Unify
---import GF.Compile.Refresh
---import GF.Compile.Compute.Abstract
-import GF.Compile.TypeCheck.TC
-
-import GF.Text.Pretty
---import Control.Monad (foldM, liftM, liftM2)
-
--- | invariant way of creating TCEnv from context
-initTCEnv gamma =
-  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
-
--- interface to TC type checker
-
-type2val :: Type -> Val
-type2val = VClos []
-
-cont2exp :: Context -> Term
-cont2exp c = mkProd c eType [] -- to check a context
-
-cont2val :: Context -> Val
-cont2val = type2val . cont2exp
-
--- some top-level batch-mode checkers for the compiler
-
-justTypeCheck :: SourceGrammar -> Term -> Val -> Err Constraints
-justTypeCheck gr e v = do
-  (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
-  (constrs1,_) <- unifyVal constrs0
-  return $ filter notJustMeta constrs1
-
-notJustMeta (c,k) = case (c,k) of
-    (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
-    _ -> True
-
-grammar2theory :: SourceGrammar -> Theory
-grammar2theory gr (m,f) = case lookupFunType gr m f of
-  Ok t -> return $ type2val t
-  Bad s -> case lookupCatContext gr m f of
-    Ok cont -> return $ cont2val cont
-    _ -> Bad s
-
-checkContext :: SourceGrammar -> Context -> [Message]
-checkContext st = checkTyp st . cont2exp
-
-checkTyp :: SourceGrammar -> Type -> [Message]
-checkTyp gr typ = err (\x -> [pp x]) ppConstrs $ justTypeCheck gr typ vType
-
-checkDef :: SourceGrammar -> Fun -> Type -> Equation -> [Message]
-checkDef gr (m,fun) typ eq = err (\x -> [pp x]) ppConstrs $ do
-  (b,cs) <- checkBranch (grammar2theory gr) (initTCEnv []) eq (type2val typ)
-  (constrs,_) <- unifyVal cs
-  return $ filter notJustMeta constrs
-
-checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String]
-checkConstrs gr cat _ = [] ---- check constructors!

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

@@ -1,324 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : TC
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/02 20:50:19 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.11 $
---
--- Thierry Coquand's type checking algorithm that creates a trace
------------------------------------------------------------------------------
-
-module GF.Compile.TypeCheck.TC (
-    AExp(..),
-    Theory,
-    checkExp,
-    inferExp,
-    checkBranch,
-    eqVal,
-    whnf
-  ) where
-
-import GF.Data.Operations
-import GF.Grammar
-import GF.Grammar.Predef
-
-import Control.Monad
---import Data.List (sortBy)
-import Data.Maybe
-import GF.Text.Pretty
-
-data AExp =
-     AVr   Ident Val
-   | ACn   QIdent Val
-   | AType
-   | AInt  Integer
-   | AFloat Double
-   | AStr  String
-   | AMeta MetaId Val
-   | ALet  (Ident,(Val,AExp)) AExp
-   | AApp  AExp AExp Val
-   | AAbs  Ident Val AExp
-   | AProd Ident AExp AExp
--- -- | AEqs  [([Exp],AExp)] --- not used
-   | ARecType [ALabelling]
-   | AR    [AAssign]
-   | AP    AExp Label Val
-   | AGlue AExp AExp
-   | AData Val
-  deriving (Eq,Show)
-
-type ALabelling = (Label, AExp)
-type AAssign = (Label, (Val, AExp))
-
-type Theory = QIdent -> Err Val
-
-lookupConst :: Theory -> QIdent -> Err Val
-lookupConst th f = th f
-
-lookupVar :: Env -> Ident -> Err Val
-lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,VClos [] (Meta 0)):g)
--- wild card IW: no error produced, ?0 instead.
-
-type TCEnv = (Int,Env,Env)
-
---emptyTCEnv :: TCEnv
---emptyTCEnv = (0,[],[])
-
-whnf :: Val -> Err Val
-whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
-         case v of
-  VApp u w -> do
-    u' <- whnf u
-    w' <- whnf w
-    app u' w'
-  VClos env e -> eval env e
-  _ -> return v
-
-app :: Val -> Val -> Err Val
-app u v = case u of
-  VClos env (Abs _ x e) -> eval ((x,v):env) e
-  _ -> return $ VApp u v
-
-eval :: Env -> Term -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
-             case e of
-  Vr x    -> lookupVar env x
-  Q c   -> return $ VCn c
-  QC c  -> return $ VCn c ---- == Q ?
-  Sort c  -> return $ VType --- the only sort is Type
-  App f a -> join $ liftM2 app (eval env f) (eval env a)
-  RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs
-                   return (VRecType xs)
-  _ -> return $ VClos env e
-
-eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
-                do
-  w1 <- whnf u1
-  w2 <- whnf u2
-  let v = VGen k
-  case (w1,w2) of
-    (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
-    (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
-      eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
-    (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
-      liftM2 (++)
-        (eqVal k     (VClos            env1  a1) (VClos            env2  a2))
-        (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
-    (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
-    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
-    --- thus ignore qualifications; valid because inheritance cannot
-    --- be qualified. Simplifies annotation. AR 17/3/2005
-    _ -> return [(w1,w2) | w1 /= w2]
--- invariant: constraints are in whnf
-
-checkType :: Theory -> TCEnv -> Term -> Err (AExp,[(Val,Val)])
-checkType th tenv e = checkExp th tenv e vType
-
-checkExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
-checkExp th tenv@(k,rho,gamma) e ty = do
-  typ <- whnf ty
-  let v = VGen k
-  case e of
-    Meta m -> return $ (AMeta m typ,[])
-
-    Abs _ x t -> case typ of
-      VClos env (Prod _ y a b) -> do
-                           a' <- whnf $ VClos env a ---
-                           (t',cs) <- checkExp th
-                                          (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
-                           return (AAbs x a' t', cs)
-      _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
-
-    Let (x, (mb_typ, e1)) e2 -> do
-      (val,e1,cs1) <- case mb_typ of
-                        Just typ -> do (_,cs1) <- checkType th tenv typ
-                                       val <- eval rho typ
-                                       (e1,cs2) <- checkExp th tenv e1 val
-                                       return (val,e1,cs1++cs2)
-                        Nothing  -> do (e1,val,cs) <- inferExp th tenv e1
-                                       return (val,e1,cs)
-      (e2,cs2) <- checkExp th (k,rho,(x,val):gamma) e2 typ
-      return (ALet (x,(val,e1)) e2, cs1++cs2)
-
-    Prod _ x a b -> do
-      testErr (typ == vType) "expected Type"
-      (a',csa) <- checkType th tenv a
-      (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
-      return (AProd x a' b', csa ++ csb)
-
-    R xs ->
-      case typ of
-        VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
-                            [] -> return ()
-                            ls -> fail (render ("no value given for label:" <+> fsep (punctuate ',' ls)))
-                          r <- mapM (checkAssign th tenv ys) xs
-                          let (xs,css) = unzip r
-                          return (AR xs, concat css)
-        _           -> Bad (render ("record type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
-
-    P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)])
-                return (AP r' l typ,cs)
-
-    Glue x y -> do cs1 <- eqVal k valAbsFloat typ
-                   (x,cs2) <- checkExp th tenv x typ
-                   (y,cs3) <- checkExp th tenv y typ
-                   return (AGlue x y,cs1++cs2++cs3)
-    _ -> checkInferExp th tenv e typ
-
-checkInferExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)])
-checkInferExp th tenv@(k,_,_) e typ = do
-  (e',w,cs1) <- inferExp th tenv e
-  cs2 <- eqVal k w typ
-  return (e',cs1 ++ cs2)
-
-inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
-inferExp th tenv@(k,rho,gamma) e = case e of
-   Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
-   Q (m,c) | m == cPredefAbs && isPredefCat c
-                     -> return (ACn (m,c) vType, vType, [])
-           | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
-   QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th c ----
-   EInt i -> return (AInt i, valAbsInt, [])
-   EFloat i -> return (AFloat i, valAbsFloat, [])
-   K i -> return (AStr i, valAbsString, [])
-   Sort _ -> return (AType, vType, [])
-   RecType xs -> do r <- mapM (checkLabelling th tenv) xs
-                    let (xs,css) = unzip r
-                    return (ARecType xs, vType, concat css)
-   Let (x, (mb_typ, e1)) e2 -> do
-    (val1,e1,cs1) <- case mb_typ of
-                       Just typ -> do (_,cs1) <- checkType th tenv typ
-                                      val <- eval rho typ
-                                      (e1,cs2) <- checkExp th tenv e1 val
-                                      return (val,e1,cs1++cs2)
-                       Nothing  -> do (e1,val,cs) <- inferExp th tenv e1
-                                      return (val,e1,cs)
-    (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
-    return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
-   App f t -> do
-    (f',w,csf) <- inferExp th tenv f
-    typ <- whnf w
-    case typ of
-      VClos env (Prod _ x a b) -> do
-        (a',csa) <- checkExp th tenv t (VClos env a)
-        b' <- whnf $ VClos ((x,VClos rho t):env) b
-        return $ (AApp f' a' b', b', csf ++ csa)
-      _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
-   _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
-
-checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)])
-checkLabelling th tenv (lbl,typ) = do
-  (atyp,cs) <- checkType th tenv typ
-  return ((lbl,atyp),cs)
-
-checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)])
-checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do
-  (atyp,cs1) <- checkType th tenv typ
-  val <- eval rho typ
-  cs2 <- case lookup lbl typs of
-           Nothing   -> return []
-           Just val0 -> eqVal k val val0
-  (aexp,cs3) <- checkExp th tenv exp val
-  return ((lbl,(val,aexp)),cs1++cs2++cs3)
-checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
-  case lookup lbl typs of
-    Nothing  -> do (aexp,val,cs) <- inferExp th tenv exp
-                   return ((lbl,(val,aexp)),cs)
-    Just val -> do (aexp,cs) <- checkExp th tenv exp val
-                   return ((lbl,(val,aexp)),cs)
-
-checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
-                                  chB tenv' ps' ty
- where
-
-  (ps',_,rho2,k') = ps2ts k ps
-  tenv' = (k, rho2++rho, gamma) ---- k' ?
-  (k,rho,gamma) = tenv
-
-  chB tenv@(k,rho,gamma) ps ty = case ps of
-    p:ps2 -> do
-      typ <- whnf ty
-      case typ of
-        VClos env (Prod _ y a b) -> do
-          a' <- whnf $ VClos env a
-          (p', sigma, binds, cs1) <- checkP tenv p y a'
-          let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
-          ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
-          return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
-        _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
-    [] -> do
-      (e,cs) <- checkExp th tenv t ty
-      return (([],e),cs)
-  checkP env@(k,rho,gamma) t x a = do
-     (delta,cs) <- checkPatt th env t a
-     let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
-     return (VClos sigma t, sigma, delta, cs)
-
-  ps2ts k = foldr p2t ([],0,[],k)
-  p2t p (ps,i,g,k) = case p of
-     PW      -> (Meta i : ps, i+1,g,k)
-     PV x    -> (Vr x   : ps, i, upd x k g,k+1)
-     PAs x p -> p2t p (ps,i,g,k)
-     PString s -> (K s : ps, i, g, k)
-     PInt n -> (EInt n : ps, i, g, k)
-     PFloat n -> (EFloat n : ps, i, g, k)
-     PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
-                    where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
-     PImplArg p -> p2t p (ps,i,g,k)
-     PTilde t -> (t : ps, i, g, k)
-     _ -> error $ render ("undefined p2t case" <+> ppPatt Unqualified 0 p <+> "in checkBranch")
-
-  upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
-
-
-checkPatt :: Theory -> TCEnv -> Term -> Val -> Err (Binds,[(Val,Val)])
-checkPatt th tenv exp val = do
-  (aexp,_,cs) <- checkExpP tenv exp val
-  let binds = extrBinds aexp
-  return (binds,cs)
- where
-   extrBinds aexp = case aexp of
-     AVr i v    -> [(i,v)]
-     AApp f a _ -> extrBinds f ++ extrBinds a
-     _ -> [] -- no other cases are possible
-
---- ad hoc, to find types of variables
-   checkExpP tenv@(k,rho,gamma) exp val = case exp of
-     Meta m -> return $ (AMeta m val, val, [])
-     Vr x   -> return $ (AVr   x val, val, [])
-     EInt i -> return (AInt i, valAbsInt, [])
-     EFloat i -> return (AFloat i, valAbsFloat, [])
-     K s    -> return (AStr s, valAbsString, [])
-
-     Q c  -> do
-       typ <- lookupConst th c
-       return $ (ACn c typ, typ, [])
-     QC c  -> do
-       typ <- lookupConst th c
-       return $ (ACn c typ, typ, []) ----
-     App f t -> do
-       (f',w,csf) <- checkExpP tenv f val
-       typ <- whnf w
-       case typ of
-         VClos env (Prod _ x a b) -> do
-           (a',_,csa) <- checkExpP tenv t (VClos env a)
-           b' <- whnf $ VClos ((x,VClos rho t):env) b
-           return $ (AApp f' a' b', b', csf ++ csa)
-         _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
-     _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
-
--- auxiliaries
-
-noConstr :: Err Val -> Err (Val,[(Val,Val)])
-noConstr er = er >>= (\v -> return (v,[]))
-
-mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
-mkAnnot a ti = do
-  (v,cs) <- ti
-  return (a v, v, cs)

src/compiler/api/GF/Compile/Update.hs

@@ -82,7 +82,7 @@ extendModule cwd gr (name,m)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
-rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) =
+rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
   checkInModule cwd mi NoLoc empty $ do
 
 ----  deps <- moduleDeps ms
@@ -119,7 +119,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
                     else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete)
              (checkError ("module" <+> i <+> "remains incomplete"))
-      ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    [OQualif i j | (i,j) <- ops] ++
@@ -135,7 +135,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j
                                     js
       let js1 = Map.union js0 js_
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1
 
   return (i,mi')
 
@@ -174,14 +174,14 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
       (b,n') = case info of
         ResValue _ _ -> (True,n)
         ResParam _ _ -> (True,n)
-        AbsFun _ _ Nothing _ -> (True,n)
+        AbsFun _ Nothing -> (True,n)
         AnyInd b k -> (b,k)
         _ -> (False,n) ---- canonical in Abs
 
 globalizeLoc fpath i =
   case i of
     AbsCat mc             -> AbsCat (fmap gl mc)
-    AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
+    AbsFun mt md          -> AbsFun (fmap gl mt) (fmap (\(a,eqs) -> (a,fmap gl eqs)) md)
     ResParam mt mv        -> ResParam (fmap gl mt) mv
     ResValue t i          -> ResValue (gl t) i
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
@@ -200,8 +200,8 @@ unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
 unifyAnyInfo m i j = case (i,j) of
   (AbsCat mc1, AbsCat mc2) ->
     liftM AbsCat (unifyMaybeL mc1 mc2)
-  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
+  (AbsFun mt1 md1, AbsFun mt2 md2) ->
-    liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
+    liftM2 AbsFun (unifyMaybeL mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
@@ -214,7 +214,7 @@ unifyAnyInfo m i j = case (i,j) of
     liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
 
   (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
-    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2)  (unifyMaybe mpmcfg1 mpmcfg2)
+    liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2)
   (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
     liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
 
@@ -229,10 +229,7 @@ unifyAnyInfo m i j = case (i,j) of
 unifyMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a))
 unifyMaybeL = unifyMaybeBy unLoc
 
-unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
+unifAbsDefs :: Maybe (Int,[L Equation]) -> Maybe (Int,[L Equation]) -> Err (Maybe (Int,[L Equation]))
-unifAbsArrity = unifyMaybe
+unifAbsDefs (Just (_,xs)) (Just (_,ys)) = return (Just (0,xs ++ ys))
-
+unifAbsDefs Nothing       Nothing       = return Nothing
-unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation])
+unifAbsDefs _             _             = fail ""
-unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
-unifAbsDefs Nothing   Nothing   = return Nothing
-unifAbsDefs _         _         = fail ""

src/compiler/api/GF/Compile/pgf.schema.json

@@ -203,7 +203,6 @@
           "type": "string",
           "enum": [
             "SymCat",
-            "SymLit",
             "SymVar",
             "SymKS",
             "SymKP",

src/compiler/api/GF/Compiler.hs

@@ -1,7 +1,7 @@
 module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where
 
 import PGF2
-import PGF2.Transactions
+import PGF2.Transactions hiding (Rule(..))
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -11,11 +11,10 @@ import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
 import GF.Grammar.CFG
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar hiding (Rule(..))
 import GF.Grammar.JSON(grammar2json)
 import GF.Grammar.Printer(TermPrintQual(..),ppModule)
 
---import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.Infra.CheckM

src/compiler/api/GF/Data/Operations.hs

@@ -35,9 +35,6 @@ module GF.Data.Operations (
      prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
      numberedParagraphs, prConjList, prIfEmpty, wrapLines,
 
-     -- ** Topological sorting
-     topoTest, topoTest2,
-
      -- ** Misc
      readIntArg,
      iterFix,  chunks,
@@ -53,7 +50,6 @@ import Control.Monad (liftM,liftM2) --,ap
 import Control.Monad.Fix
 
 import GF.Data.ErrM
-import GF.Data.Relation
 import qualified Control.Monad.Fail as Fail
 
 infixr 5 +++
@@ -188,26 +184,6 @@ wrapLines n s@(c:cs) =
                      l = length w
             _ -> s -- give up!!
 
--- | Topological sorting with test of cyclicity
-topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
-topoTest = topologicalSort . mkRel'
-
--- | Topological sorting with test of cyclicity, new version /TH 2012-06-26
-topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
-topoTest2 g0 = maybe (Right cycles) Left (tsort g)
-  where
-    g = g0++[(n,[])|n<-nub (concatMap snd g0)\\map fst g0]
-
-    cycles = findCycles (mkRel' g)
-
-    tsort nes =
-      case partition (null.snd) nes of
-        ([],[]) -> Just []
-        ([],_) -> Nothing
-        (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
-            where leaves = map fst ns
-
-
 -- | Fix point iterator (for computing e.g. transitive closures or reachability)
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
 iterFix more start = iter start start

src/compiler/api/GF/Data/XML.hs

@@ -4,7 +4,7 @@
 --
 -- Utilities for creating XML documents.
 ----------------------------------------------------------------------
-module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, showsNospaceXML, bottomUpXML, parseXML) where
 
 import Data.Char(isSpace)
 import Numeric (readHex)
@@ -38,6 +38,17 @@ showsXML = showsX 0 where
     (Empty) -> id
   ind i = showString ("\n" ++ replicate (2*i) ' ')
 
+showsNospaceXML :: XML -> ShowS
+showsNospaceXML x = case x of
+    (Data s) -> showString (escape s)
+    (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>"
+    (Tag t as cs) ->
+      showChar '<' . showString t . showsAttrs as . showChar '>' .
+      concatS (map showsNospaceXML cs) .
+      showString "</" . showString t . showChar '>'
+    (Comment c) -> showString "<!-- " . showString c . showString " -->"
+    (Empty) -> id
+
 showsAttrs :: [Attr] -> ShowS
 showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
 

src/compiler/api/GF/Grammar.hs

@@ -14,7 +14,6 @@
 
 module GF.Grammar
            ( module GF.Grammar.Grammar,
-             module GF.Grammar.Values,
              module GF.Grammar.Macros,
              module GF.Grammar.Parser,
              module GF.Grammar.Printer,
@@ -23,7 +22,6 @@ module GF.Grammar
            ) where
 
 import GF.Grammar.Grammar
-import GF.Grammar.Values
 import GF.Grammar.Macros
 import GF.Grammar.Parser
 import GF.Grammar.Printer

src/compiler/api/GF/Grammar/Analyse.hs

@@ -27,7 +27,7 @@ stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)})
 stripInfo :: Info -> Info
 stripInfo i = case i of
   AbsCat _ -> i
-  AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
+  AbsFun mt me -> AbsFun mt Nothing
   ResParam mp mt -> ResParam mp Nothing
   ResValue lt _ -> i ----
   ResOper mt md -> ResOper mt Nothing
@@ -87,9 +87,9 @@ sizeTerm t = case t of
   Table a c    -> 1 + sizeTerm a + sizeTerm c
   ExtR a c     -> 1 + sizeTerm a + sizeTerm c
   R r          -> 1 + sum [1 + sizeTerm a | (_,(_,a)) <- r]  -- label counts as 1, type ignored
-  RecType r    -> 1 + sum [1 + sizeTerm a | (_,a)     <- r]  -- label counts as 1
+  RecType r    -> 1 + sum [1 + sizeTerm a | (_,_,a)   <- r]  -- label counts as 1
   P t i        -> 2 + sizeTerm t
-  T _ cc       -> 1 + sum [1 + sizeTerm (patt2term p) + sizeTerm v | (p,v) <- cc]
+  T _ cc       -> 1 + sum [1 + sizePatt p + sizeTerm v | (p,v) <- cc]
   V ty cc      -> 1 + sizeTerm ty + sum [1 + sizeTerm v | v <- cc]
   Let (x,(mt,a)) b -> 2 + maybe 0 sizeTerm mt + sizeTerm a + sizeTerm b
   C s1 s2      -> 1 + sizeTerm s1 + sizeTerm s2 
@@ -99,13 +99,25 @@ sizeTerm t = case t of
   Strs tt      -> 1 + sum (map sizeTerm tt)
   _            -> 1
 
+sizePatt :: Patt -> Int
+sizePatt p = case p of
+  PC c pp   -> 1 + sum (map sizePatt pp)
+  PP c pp   -> 1 + sum (map sizePatt pp)
+  PR r      -> 1 + sum [sizePatt p | (l,p) <- r]
+  PT _ p    -> sizePatt p
+  PAs _ p   -> sizePatt p
+  PSeq _ _ a _ _ b  -> 1 + sizePatt a + sizePatt b
+  PAlt a b  -> 1 + sizePatt a + sizePatt b
+  PRep _ _ a-> 1 + sizePatt a
+  PNeg a    -> 1 + sizePatt a
+  _         -> 1
 
 -- the size of a judgement
 sizeInfo :: Info -> Int
 sizeInfo i = case i of
   AbsCat (Just (L _ co)) -> 1 + sum [1 + sizeTerm ty | (_,_,ty) <- co]
-  AbsFun mt mi me mb -> 1 + msize mt + 
+  AbsFun mt me -> 1 + msize mt + 
-    sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
+    sum [sum (map sizePatt ps) + sizeTerm t | Just (_,es) <- [me], L _ (ps,t) <- es]
   ResParam mp mt -> 
     1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
   ResValue _ _ -> 0

src/compiler/api/GF/Grammar/Binary.hs

@@ -23,7 +23,6 @@ import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
 import PGF2(Literal(..))
-import PGF2.Transactions(Symbol(..))
 
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF05"
@@ -33,9 +32,9 @@ instance Binary Grammar where
   get = fmap mGrammar get
 
 instance Binary ModuleInfo where
-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
-  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
-              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
 
 instance Binary ModuleType where
   put MTAbstract       = putWord8 0
@@ -100,13 +99,13 @@ instance Binary PArg where
   put (PArg x y) = put (x,y)
   get = get >>= \(x,y) -> return (PArg x y)
 
-instance Binary Production where
+instance Binary Rule where
-  put (Production ps args res rules) = put (ps,args,res,rules)
+  put (Rule v w x y z) = put (v,w,x,y,z)
-  get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
+  get = get >>= \(v,w,x,y,z) -> return (Rule v w x y z)
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
-  put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
+  put (AbsFun x y)     = putWord8 1 >> put (x,y)
   put (ResParam x y)   = putWord8 2 >> put (x,y)
   put (ResValue x y)   = putWord8 3 >> put (x,y)
   put (ResOper x y)    = putWord8 4 >> put (x,y)
@@ -117,7 +116,7 @@ instance Binary Info where
   get = do tag <- getWord8
            case tag of
              0 -> get >>= \x         -> return (AbsCat x)
-             1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
+             1 -> get >>= \(x,y)     -> return (AbsFun x y)
              2 -> get >>= \(x,y)     -> return (ResParam x y)
              3 -> get >>= \(x,y)     -> return (ResValue x y)
              4 -> get >>= \(x,y)     -> return (ResOper x y)
@@ -225,7 +224,6 @@ instance Binary Patt where
   put (PC x y)     = putWord8  0 >> put (x,y)
   put (PP x y)     = putWord8  1 >> put (x,y)
   put (PV x)       = putWord8  2 >> put x
-  put (PW)         = putWord8  3
   put (PR x)       = putWord8  4 >> put x
   put (PString x)  = putWord8  5 >> put x
   put (PInt    x)  = putWord8  6 >> put x
@@ -247,7 +245,6 @@ instance Binary Patt where
              0  -> get >>= \(x,y)   -> return (PC x y)
              1  -> get >>= \(x,y)   -> return (PP x y)
              2  -> get >>= \x       -> return (PV x)
-             3  ->                     return (PW)
              4  -> get >>= \x       -> return (PR x)
              5  -> get >>= \x       -> return (PString x)
              6  -> get >>= \x       -> return (PInt    x)
@@ -310,7 +307,6 @@ instance Binary Literal where
 
 instance Binary Symbol where
   put (SymCat d r)       = putWord8 0 >> put (d,r)
-  put (SymLit d r)       = putWord8 1 >> put (d,r)
   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)
@@ -323,7 +319,6 @@ instance Binary Symbol where
   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
@@ -369,7 +364,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
 decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
   where
     conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
-        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
+        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty)
 
 encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
 encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)

src/compiler/api/GF/Grammar/Grammar.hs

@@ -65,7 +65,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
+        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..)
         ) where
 
 import GF.Infra.Ident
@@ -75,8 +75,9 @@ import GF.Infra.Location
 import GF.Data.Operations
 
 import PGF2(BindType(..),PGF)
-import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
+import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..))
 
+import Data.Graph
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
 import qualified Data.Map as Map
@@ -103,7 +104,6 @@ data ModuleInfo
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Seq.Seq [Symbol]),
     jments  :: Map.Map Ident Info
    }
  | ModPGF {
@@ -277,10 +277,11 @@ isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
 
 -- | all abstract modules sorted from least to most dependent
 allAbstracts :: Grammar -> [ModuleName]
-allAbstracts gr = 
+allAbstracts gr =
- case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
+ let scc = stronglyConnComp [(mn,mn,extends mo) | (mn,mo) <- modules gr, mtype mo == MTAbstract]
-   Left  is     -> is
+ in case [mns | CyclicSCC mns <- scc] of
-   Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
+      []     -> [mn | AcyclicSCC mn <- scc]
+      cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
 
 -- | the last abstract in dependency order (head of list)
 greatestAbstract :: Grammar -> Maybe ModuleName
@@ -322,8 +323,8 @@ allConcreteModules gr =
 -- and indirection to module (/INDIR/)
 data Info =
 -- judgements in abstract syntax
-   AbsCat   (Maybe (L Context))                                            -- ^ (/ABS/) context of a category
+   AbsCat   (Maybe (L Context))                         -- ^ (/ABS/) context of a category
- | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
+ | AbsFun   (Maybe (L Type)) (Maybe (Int,[L Equation])) -- ^ (/ABS/) type, arrity and definition of a function
 
 -- judgements in resource
  | ResParam (Maybe (L [Param])) (Maybe ([Term],Int)) -- ^ (/RES/) The second argument is list of all possible values
@@ -336,12 +337,12 @@ data Info =
  | ResOverload [ModuleName] [(L Type,L Term)]        -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed, 
+ | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Rule],[Rule])) -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
+ | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Rule]) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
-  deriving Show
+  deriving (Eq,Show)
 
 type Type    = Term
 type Cat     = QIdent
@@ -396,7 +397,7 @@ data Term =
 
  | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
 
- | Markup Ident [(Ident,Term)] [Term]
+ | Markup Ident [(Ident,Term)] [L Term]
  | Reset Ident (Maybe Term) Term (Maybe QIdent)
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
@@ -409,8 +410,7 @@ data Term =
 data Patt =
    PC Ident [Patt]        -- ^ constructor pattern: @C p1 ... pn@    @C@ 
  | PP QIdent [Patt]       -- ^ package constructor pattern: @P.C p1 ... pn@    @P.C@ 
- | PV Ident               -- ^ variable pattern: @x@
+ | PV Ident               -- ^ variable pattern: @x@ or wild card @_@
- | PW                     -- ^ wild card pattern: @_@
  | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@  -- only concrete
  | PString String         -- ^ string literal pattern: @\"foo\"@  -- only abstract
  | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
@@ -462,8 +462,8 @@ type Hypo     = (BindType,Ident,Type)   -- (x:A)  (_:A)  A  ({x}:A)
 type Context  = [Hypo]                  -- (x:A)(y:B)   (x,y:A)   (_,_:A)
 type Equation = ([Patt],Term) 
 
-type Labelling = (Label, Type) 
+type Labelling = (Label, [Ident], Type)
-type Assign = (Label, (Maybe Type, Term)) 
+type Assign = (Label, (Maybe Type, Term))
 type Option = (Maybe Term, Term)
 type Case = (Patt, Term) 
 --type Cases = ([Patt], Term) 

src/compiler/api/GF/Grammar/JSON.hs

@@ -34,11 +34,11 @@ info2json (AbsCat mb_ctxt) =
   case mb_ctxt of
     Nothing         -> makeObj []
     Just (L _ ctxt) -> makeObj [("context", showJSON (map hypo2json ctxt))]
-info2json (AbsFun mb_ty mb_arity mb_eqs _) =
+info2json (AbsFun mb_ty mb_eqs) =
   (makeObj . catMaybes)
      [ fmap (\(L _ ty) -> ("abstype",term2json ty)) mb_ty
-     , fmap (\a -> ("arity",showJSON a)) mb_arity
+     , fmap (\(a,_)   -> ("arity",showJSON a)) mb_eqs
-     , fmap (\eqs -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
+     , fmap (\(_,eqs) -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
      ]
 info2json (ResParam mb_params _) =
   makeObj [("params", case mb_params of
@@ -102,7 +102,7 @@ term2json (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("
 term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)]
 term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)]
 term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
-                              where toRow (l,t) = (showLabel l, term2json t)
+                              where toRow (l,_,t) = (showLabel l, term2json t)
 term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
                               where toRow (l,(_,t)) = (showLabel l, term2json t)
 term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))]
@@ -126,7 +126,7 @@ term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
 term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
 term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
                                                 , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
-                                                , ("children",showJSON (map term2json children))
+                                                , ("children",showJSON (map (term2json . unLoc) children))
                                                 ]
 term2json (Reset ctl ct t qid) =
   makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
@@ -177,14 +177,14 @@ json2term o  = Vr      <$> o!:"vr"
     <|>        FV      <$> (o!:"variants" >>= mapM json2term)
     <|>        Markup  <$> (o!:"tag") <*>
                            (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
-                           (o!:"children" >>= mapM json2term)
+                           (o!:"children" >>= mapM (fmap noLoc . json2term))
     <|>        Reset   <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
     <|>        Reset   <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
     <|>        Alts    <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))
     <|>        Strs    <$> (o!:"strs" >>= mapM json2term)
     where
       fromRow  (lbl, jsvalue) = do value <- json2term jsvalue
-                                   return (readLabel lbl,value)
+                                   return (readLabel lbl,[],value)
 
       fromRow' (lbl, jsvalue) = do value <- json2term jsvalue
                                    return (readLabel lbl,(Nothing,value))
@@ -198,7 +198,6 @@ json2term o  = Vr      <$> o!:"vr"
 patt2json (PC id ps)     = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
 patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
 patt2json (PV id)        = makeObj [("pv",showJSON id)]
-patt2json PW             = makeObj [("wildcard",showJSON True)]
 patt2json (PR lbls)      = makeObj (("record", showJSON True) : map toRow lbls)
                                where toRow (l,t) = (showLabel l, patt2json t)
 patt2json (PString s)    = showJSON s
@@ -231,7 +230,6 @@ json2patt :: JSValue -> Result Patt
 json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt)
     <|>       PC <$> (o!:"pc") <*> (o!:"args" >>= mapM json2patt)
     <|>       PV <$> (o!:"pv")
-    <|>  (o!:"wildcard" >>= guard >> return PW)
     <|> (const PR) <$> (o!:"record" >>= guard) <*> mapM fromRow (assocsJSObject o)
     <|>  PString <$> readJSON o
     <|>  PInt    <$> readJSON o

src/compiler/api/GF/Grammar/Lockfield.hs

@@ -14,37 +14,35 @@
 -- AR 8\/2\/2005 detached from 'compile/MkResource'
 -----------------------------------------------------------------------------
 
-module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
+module GF.Grammar.Lockfield (lock, lockLabel, isLockLabel) where
 
 import GF.Infra.Ident
+import GF.Grammar.Predef
 import GF.Grammar.Grammar
-import GF.Grammar.Macros
 
 import GF.Data.Operations(ErrorMonad,Err(..))
 
-lockRecType :: ErrorMonad m => Ident -> Type -> m Type
+lock :: Ident -> Term -> Term
-lockRecType c t@(RecType rs) = 
+lock c t@(RecType rs) =
-  let lab = lockLabel c in
+  let lbl = lockLabel c
-  return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
+  in if null [l | (l,_,_)<-rs, l == lbl]
-    then t --- don't add an extra copy of lock field, nor predef cats
+       then RecType (rs ++ [(lbl, [], RecType [])])
-    else RecType (rs ++ [(lockLabel c,  RecType [])])
+       else t --- don't add an extra copy of lock field, nor predef cats
-lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
+lock c t@(R rs) =
-
+  let lbl = lockLabel c
-unlockRecord :: Monad m => Ident -> Term -> m Term
+  in if elem lbl (map fst rs)
-unlockRecord c ft = do
+       then t
-  let (xs,t) = termFormCnc ft
+       else R (rs ++ [(lbl, (Just (RecType []),R []))])
-  let lock = R [(lockLabel c,  (Just (RecType []),R []))]
+lock c (Abs b x t) = Abs b x (lock c t)
-  case plusRecord t lock of
+lock c (FV ts)     = FV (map (lock c) ts)
-    Ok t' -> return $ mkAbs xs t'
+lock c t           = t
-    _ -> return $ mkAbs xs (ExtR t lock)
 
 lockLabel :: Ident -> Label
 lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c)
 
-isLockLabel :: Label -> Bool
+isLockLabel :: Label -> Maybe RawIdent
 isLockLabel l = case l of
   LIdent c -> isPrefixOf lockPrefix c
-  _        -> False
+  _        -> Nothing
-
 
 lockPrefix = rawIdentS "lock_"

src/compiler/api/GF/Grammar/Lookup.hs

@@ -23,9 +23,10 @@ module GF.Grammar.Lookup (
            lookupResType,
            lookupOverload,
            lookupOverloadTypes,
-           lookupParamValues,
            allParamValues,
+           countParamValues,
            lookupAbsDef,
+           lookupAbsType,
            lookupLincat,
            lookupFunType,
            lookupCatContext,
@@ -45,10 +46,6 @@ import GF.Text.Pretty
 import qualified Data.Map as Map
 import qualified PGF2
 
--- whether lock fields are added in reuse
-lock c = lockRecType c -- return
-unlock c = unlockRecord c -- return
-
 -- to look up a constant etc in a search tree --- why here? AR 29/5/2008
 lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b
 lookupIdent c t =
@@ -77,7 +74,8 @@ lookupIdentInfo (m,ModPGF{mpgf=pgf})   i =
     appHypos []                  xs t es =
       foldl (appExpr xs) t es
     appHypos ((bt, v, ty):hypos) xs t es =
-      let x = identS v in Prod bt x (cnvType xs ty) (appHypos hypos (x:xs) t es)
+      let x = if v == "_" then identW else identS v
+      in Prod bt x (cnvType xs ty) (appHypos hypos (x:xs) t es)
 
     appExpr xs t e = App t (cnvExpr xs e)
 
@@ -101,7 +99,7 @@ lookupQIdentInfo gr (m,c) = do
 
 lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term
 lookupResDef gr (m,c)
-  | isPredefCat c = lock c defLinType
+  | isPredefCat c = return (lock c defLinType)
   | otherwise     = look m c
   where
     look m c = do
@@ -109,10 +107,10 @@ lookupResDef gr (m,c)
       case info of
         ResOper _ (Just (L _ t)) -> return t
         ResOper _ Nothing  -> return (Q (m,c))
-        CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty
+        CncCat (Just (L _ ty)) _ _ _ _ -> return (lock c ty)
-        CncCat _ _ _ _ _         -> lock c defLinType
+        CncCat _ _ _ _ _        -> return (lock c defLinType)
 
-        CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr
+        CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> return (lock cat tr)
         CncFun _                  (Just (L _ tr)) _ _ -> return tr
 
         AnyInd _ n        -> look n c
@@ -128,9 +126,8 @@ lookupResType gr (m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
-    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
+    CncFun (Just (args,cat,cont,val)) _ _ _ ->
-          val' <- lock cat val
+           return $ (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) (lock cat val))
-          return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _    -> return typePType
     ResValue (L _ t) _ -> return t
@@ -145,8 +142,7 @@ lookupOverloadTypes gr id@(m,c) = do
     -- used in reused concrete
     CncCat _ _ _ _ _ -> ret typeType
     CncFun (Just (_,cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val
+          ret $ mkProd cont (lock cat val) []
-          ret $ mkProd cont val' []
     ResParam _ _    -> ret typePType
     ResValue (L _ t) _ -> ret t
     ResOverload os tysts -> do
@@ -186,42 +182,60 @@ allOrigInfos gr m = fromErr [] $ do
     ModInfo{jments=jments} -> return [((m,c),i) | (c,_) <- Map.toList jments, Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
     _                      -> return []
 
-lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
-lookupParamValues gr c = do
-  (_,info) <- lookupOrigInfo gr c
-  case info of
-    ResParam _ (Just (pvs,_)) -> return pvs
-    _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
-
 allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
-allParamValues cnc ptyp =
+allParamValues gr ptyp =
   case ptyp of
     _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
-    QC c -> lookupParamValues cnc c
+    QC c -> do (_,info) <- lookupOrigInfo gr c
-    Q  c -> lookupResDef cnc c >>= allParamValues cnc
+               case info of
+                 ResParam _ (Just (pvs,_)) -> return pvs
+                 _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+    Q  c -> lookupResDef gr c >>= allParamValues gr
     RecType r -> do
-       let (ls,tys) = unzip $ sortByFst r
+       let (ls,lls,tys) = unzip3 $ sortByLbl r
-       tss <- mapM (allParamValues cnc) tys
+       tss <- mapM (allParamValues gr) tys
        return [R (zipAssign ls ts) | ts <- sequence tss]
     Table pt vt -> do
-       pvs <- allParamValues cnc pt
+       pvs <- allParamValues gr pt
-       vvs <- allParamValues cnc vt
+       vvs <- allParamValues gr vt
        return [V pt ts | ts <- sequence (replicate (length pvs) vvs)]
     _ -> raise (render ("cannot find parameter values for" <+> ptyp))
   where
     -- to normalize records and record types
-    sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+    sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
 
-lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation])
+countParamValues :: ErrorMonad m => Grammar -> Type -> m Int
-lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
+countParamValues gr ptyp =
-  info <- lookupQIdentInfo gr (m,c)
+  case ptyp of
+    _ | Just n <- isTypeInts ptyp -> return (fromIntegral n+1)
+    QC c -> do (_,info) <- lookupOrigInfo gr c
+               case info of
+                 ResParam _ (Just (_,cnt)) -> return cnt
+                 _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+    Q  c -> lookupResDef gr c >>= countParamValues gr
+    RecType r -> do
+       let (ls,lls,tys) = unzip3 $ sortByLbl r
+       cs <- mapM (countParamValues gr) tys
+       return (product cs)
+    Table pt vt -> do
+       pc <- countParamValues gr pt
+       vc <- countParamValues gr vt
+       return (vc ^ pc)
+    _ -> raise (render ("cannot find parameter values for" <+> ptyp))
+  where
+    -- to normalize records and record types
+    sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2)
+
+lookupAbsDef :: ErrorMonad m => Grammar -> QIdent -> m (Maybe (Int,[Equation]))
+lookupAbsDef gr q@(m,c) = errIn (render ("looking up absdef of" <+> c)) $ do
+  info <- lookupQIdentInfo gr q
   case info of
-    AbsFun _ a d _ -> return (a,fmap (map unLoc) d)
+    AbsFun a d -> return (fmap (\(a,eqs) -> (a,map unLoc eqs)) d)
-    AnyInd _ n     -> lookupAbsDef gr n c
+    AnyInd _ n -> lookupAbsDef gr (n,c)
-    _              -> return (Nothing,Nothing)
+    _          -> return Nothing
 
 lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
-lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
+lookupLincat gr m c | isPredefCat c = return (lock c defLinType) --- ad hoc; not needed?
 lookupLincat gr m c = do
   info <- lookupQIdentInfo gr (m,c)
   case info of
@@ -230,13 +244,31 @@ lookupLincat gr m c = do
     _                             -> raise (render (c <+> "has no linearization type in" <+> m))
 
 -- | this is needed at compile time
-lookupFunType :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type
+lookupAbsType :: ErrorMonad m => Grammar -> QIdent -> m (Term,Type)
-lookupFunType gr m c = do
+lookupAbsType gr q@(m,c)
-  info <- lookupQIdentInfo gr (m,c)
+  | m == cPredefAbs =
+      if isPredefCat c
+        then return (QC q,typeType)
+        else no_type
+  | otherwise = do
+      info <- lookupQIdentInfo gr q
+      case info of
+        AbsCat (Just (L _ co))         -> return (QC q,mkProd co typeType [])
+        AbsFun (Just (L _ t)) Nothing  -> return (QC q,t)
+        AbsFun (Just (L _ t)) (Just _) -> return (Q q,t)
+        AnyInd _ n                     -> lookupAbsType gr (n,c)
+        _                              -> no_type
+  where
+    no_type = raise (render ("cannot find type of" <+> c))
+
+-- | this is needed at compile time
+lookupFunType :: ErrorMonad m => Grammar -> QIdent -> m Type
+lookupFunType gr q@(m,c) = do
+  info <- lookupQIdentInfo gr q
   case info of
-    AbsFun (Just (L _ t)) _ _ _ -> return t
+    AbsFun (Just (L _ t)) _ -> return t
-    AnyInd _ n                  -> lookupFunType gr n c
+    AnyInd _ n              -> lookupFunType gr (n,c)
-    _                           -> raise (render ("cannot find type of" <+> c))
+    _                       -> raise (render ("cannot find type of" <+> c))
 
 -- | this is needed at compile time
 lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context
@@ -260,18 +292,14 @@ allOpers gr =
   ]
   where
     typesIn info = case info of
-      AbsFun  (Just ltyp) _ _ _ -> [ltyp]
+      AbsFun  (Just ltyp) _     -> [ltyp]
       ResOper (Just ltyp) _     -> [ltyp]
       ResValue ltyp _           -> [ltyp]
       ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
       CncFun  (Just (_,i,ctx,typ)) _ _ _ ->
-                                   [L NoLoc (mkProdSimple ctx (lock' i typ))]
+                                   [L NoLoc (mkProdSimple ctx (lock i typ))]
       _                         -> []
 
-    lock' i typ = case lock i typ of
-                    Ok t -> t
-                    _ -> typ
-
 --- not for dependent types
 allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)]
 allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where

src/compiler/api/GF/Grammar/Macros.hs

@@ -28,10 +28,12 @@ import GF.Grammar.Printer
 import Control.Monad.Identity(Identity(..))
 import qualified Data.Traversable as T(mapM)
 import qualified Data.Map as Map
-import Control.Monad (liftM, liftM2, liftM3)
+import Control.Monad (liftM, liftM2, liftM3, forM)
-import Data.List (sortBy,nub)
+import Data.List (nub)
+import Data.Maybe (fromMaybe)
 import Data.Monoid
-import GF.Text.Pretty(render,(<+>),hsep,fsep)
+import Data.Graph
+import GF.Text.Pretty(render,(<+>),($$),hsep,fsep,vcat,nest)
 import qualified Control.Monad.Fail as Fail
 
 -- ** Functions for constructing and analysing source code terms.
@@ -179,6 +181,9 @@ mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
 mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
   where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
 
+mapLabellingM :: Monad m => (Term -> m c) -> [Labelling] -> m [(Label,[Ident],c)]
+mapLabellingM f = mapM (\(l,deps,t) -> f t >>= \t -> return (l,deps,t))
+
 mapAttrs :: Monad m => (Term -> m c) -> [(Ident,Term)] -> m [(Ident,c)]
 mapAttrs f []          = return []
 mapAttrs f ((id,t):as) = do t  <- f t
@@ -193,7 +198,7 @@ mkRecord :: (Int -> Label) -> [Term] -> Term
 mkRecord = mkRecordN 0
 
 mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
-mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
+mkRecTypeN int lab typs = RecType [(lab i, [], t) | (i,t) <- zip [int..] typs]
 
 mkRecType :: (Int -> Label) -> [Type] -> Type
 mkRecType = mkRecTypeN 0
@@ -260,7 +265,7 @@ tuple2record :: [Term] -> [Assign]
 tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
 
 tuple2recordType :: [Term] -> [Labelling]
-tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+tuple2recordType ts = [(tupleLabel i,[],t) | (i,t) <- zip [1..] ts]
 
 tuple2recordPatt :: [Patt] -> [(Label,Patt)]
 tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
@@ -277,7 +282,7 @@ mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
 --plusRecType :: Type -> Type -> Err Type
 plusRecType t1 t2 = case (t1, t2) of
   (RecType r1, RecType r2) -> case
-    filter (`elem` (map fst r1)) (map fst r2) of
+    filter (`elem` [l | (l,_,_) <- r1]) [l | (l,_,_) <- r2] of
       [] -> return (RecType (r1 ++ r2))
       ls -> raise $ render ("clashing labels" <+> hsep ls)
   _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
@@ -293,7 +298,7 @@ plusRecord t1 t2 =
 
 -- | default linearization type
 defLinType :: Type
-defLinType = RecType [(theLinLabel,  typeStr)]
+defLinType = RecType [(theLinLabel, [], typeStr)]
 
 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident -> Ident
@@ -308,83 +313,6 @@ mkFreshVar olds x =
 mkFreshVarX :: [Ident] -> Ident -> Ident
 mkFreshVarX olds x = if (elem x olds) then (varX (maximum ((-1) : (map varIndex olds)) + 1)) else x
 
--- *** Term and pattern conversion
-
-term2patt :: Term -> Err Patt
-term2patt trm = case termForm trm of
-  Ok ([], Vr x, []) | x == identW -> return PW
-                    | otherwise   -> return (PV x)
-  Ok ([], Con c, aa) -> do
-    aa' <- mapM term2patt aa
-    return (PC c aa')
-  Ok ([], QC  c, aa) -> do
-    aa' <- mapM term2patt aa
-    return (PP c aa')
-
-  Ok ([], Q c, []) -> do
-    return (PM c)
-
-  Ok ([], R r, []) -> do
-    let (ll,aa) = unzipR r
-    aa' <- mapM term2patt aa
-    return (PR (zip ll aa'))
-  Ok ([],EInt i,[]) -> return $ PInt i
-  Ok ([],EFloat i,[]) -> return $ PFloat i
-  Ok ([],K s,   []) -> return $ PString s
-
---- encodings due to excessive use of term-patt convs. AR 7/1/2005
-  Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
-    b' <- term2patt b
-    return (PAs a b')
-  Ok ([], Cn id, [a]) | id == cNeg  -> do
-    a' <- term2patt a
-    return (PNeg a')
-  Ok ([], Cn id, [a]) | id == cRep -> do
-    a' <- term2patt a
-    return (PRep 0 Nothing a')
-  Ok ([], Cn id, []) | id == cRep -> do
-    return PChar
-  Ok ([], Cn id,[K s]) | id == cChars  -> do
-    return $ PChars s
-  Ok ([], Cn id, [a,b]) | id == cSeq -> do
-    a' <- term2patt a
-    b' <- term2patt b
-    return (PSeq 0 Nothing a' 0 Nothing b')
-  Ok ([], Cn id, [a,b]) | id == cAlt -> do
-    a' <- term2patt a
-    b' <- term2patt b
-    return (PAlt a' b')
-
-  Ok ([], Cn c, []) -> do
-    return (PMacro c)
-
-  _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
-
-patt2term :: Patt -> Term
-patt2term pt = case pt of
-  PV x      -> Vr x
-  PW        -> Vr identW             --- not parsable, should not occur
-  PMacro c  -> Cn c
-  PM c      -> Q c
-
-  PC c pp   -> mkApp (Con c) (map patt2term pp)
-  PP c pp   -> mkApp (QC  c) (map patt2term pp)
-
-  PR r      -> R [assign l (patt2term p) | (l,p) <- r]
-  PT _ p    -> patt2term p
-  PInt i    -> EInt i
-  PFloat i  -> EFloat i
-  PString s -> K s
-
-  PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
-  PChar     -> appCons cChar  []                             --- an encoding
-  PChars s  -> appCons cChars [K s]                          --- an encoding
-  PSeq _ _ a _ _ b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
-  PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
-  PRep _ _ a-> appCons cRep   [(patt2term a)]                --- an encoding
-  PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
-
-
 -- *** Almost compositional
 
 -- | to define compositional term functions
@@ -401,7 +329,7 @@ composOp co trm =
    S c a            -> liftM2 S (co c) (co a)
    Table a c        -> liftM2 Table (co a) (co c)
    R r              -> liftM R (mapAssignM co r)
-   RecType r        -> liftM RecType (mapPairsM co r)
+   RecType r        -> liftM RecType (mapLabellingM co r)
    P t i            -> liftM2 P (co t) (return i)
    ExtR a c         -> liftM2 ExtR (co a) (co c)
    Opts t os        -> liftM2 Opts (co t) (mapM (\(t1,t2) -> liftM2 (,) (maybe (return Nothing) (liftM Just . co) t1) (co t2)) os)
@@ -418,7 +346,7 @@ composOp co trm =
    ELincat c ty     -> liftM (ELincat c) (co ty)
    ELin c ty        -> liftM (ELin c) (co ty)
    ImplArg t        -> liftM ImplArg (co t)
-   Markup t as cs   -> liftM2 (Markup t) (mapAttrs co as) (mapM co cs)
+   Markup t as cs   -> liftM2 (Markup t) (mapAttrs co as) (mapM (mapM co) cs)
    Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t)
    Typed t ty       -> liftM2 Typed (co t) (co ty)
    _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
@@ -452,8 +380,8 @@ collectOp co trm = case trm of
   Table a c    -> co a <> co c
   ExtR a c     -> co a <> co c
   Opts t os    -> co t <> mconcatMap (\(a,b) -> maybe mempty co a <> co b) os
-  R r          -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
+  R r          -> mconcatMap (\(_,(mt,a)) -> maybe mempty co mt <> co a) r
-  RecType r    -> mconcatMap (co . snd) r
+  RecType r    -> mconcatMap (\(_,_,t) -> co t) r
   P t i        -> co t
   T _ cc       -> mconcatMap (co . snd) cc -- not from patterns --- nor from type annot
   V _ cc       -> mconcatMap co         cc --- nor from type annot
@@ -466,7 +394,7 @@ collectOp co trm = case trm of
   Strs tt      -> mconcatMap co tt
   ELincat _ t  -> co t
   ELin _ t     -> co t
-  Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
+  Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap (co . unLoc) cs
   Reset _ ct t _-> maybe mempty co ct <> co t
   _            -> mempty -- covers K, Vr, Cn, Sort
 
@@ -524,58 +452,55 @@ changeTableType co i = case i of
     TWild ty  -> co ty >>= return . TWild
     _ -> return i
 
--- | normalize records and record types; put s first
-
-sortRec :: [(Label,a)] -> [(Label,a)]
-sortRec = sortBy ordLabel where
-  ordLabel (r1,_) (r2,_) =
-    case (showIdent (label2ident r1), showIdent (label2ident r2)) of
-      ("s",_) -> LT
-      (_,"s") -> GT
-      (s1,s2) -> compare s1 s2
-
 -- *** Dependencies
 
 -- | dependency check, detecting circularities and returning topo-sorted list
 
-allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
+allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,Info,[Ident])]
 allDependencies ism b =
-  [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
+  [(f, i, nub (deps i)) | (f,i) <- Map.toList b]
   where
     opersIn t = case t of
       Q  (n,c) | ism n -> [c]
       QC (n,c) | ism n -> [c]
+      EPatt _ _ p -> opersInPatt p
+      T _ cs -> mconcatMap (\(p,t) -> opersInPatt p ++ opersIn t) cs
       _ -> collectOp opersIn t
+
+    constrsIn t = case t of
+      QC (n,c) | ism n -> [c]
+      _ -> collectOp constrsIn t
+
+    opersInPatt p = case p of
+      PP (n,c) ps      -> (if ism n then (:)c else id)
+                              (concatMap opersInPatt ps)
+      PTilde t         -> opersIn t
+      PM (n,c) | ism n -> [c]
+      _ -> collectPattOp opersInPatt p
+
     opty (Just (L _ ty)) = opersIn ty
     opty _ = []
-    pts i = case i of
+
-      ResOper pty pt -> [pty,pt]
+    deps i = case i of
-      ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
+      ResOper pty pt -> opty pty ++ opty pt
-      ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
+      ResOverload _ tyts -> concat [opersIn ty ++ opersIn tr | (L _ ty,L _ tr) <- tyts]
-      CncCat pty _ _ _ _ -> [pty]
+      ResParam (Just (L loc ps)) _ -> concat [opersIn  t | (_,cont) <- ps, (_,_,t) <- cont]
-      CncFun _   pt _ _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
+      CncCat pty _ _ _ _ -> opty pty
-      AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
+      CncFun _   pt _ _ -> opty pt
-      AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
+      AbsFun pty peqs -> opty pty ++ concat [concatMap opersInPatt ps++constrsIn t | L _ (ps,t) <- maybe [] snd peqs]
+      AbsCat (Just (L loc co)) -> concat [opersIn ty | (_,_,ty) <- co]
       _              -> []
 
 topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
 topoSortJments (m,mi) = do
-  is <- either
+  let sccs = stronglyConnComp (map toNode (allDependencies (==m) (jments mi)))
-          return
+      cycles = [map fst jmts | CyclicSCC jmts <- sccs]
-          (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
+  case cycles of
-          (topoTest (allDependencies (==m) (jments mi)))
+    [] -> return [jmt | AcyclicSCC jmt <- sccs]
-  return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])
+    _  -> raise (render ("circular definitions:" $$
-
+                             nest 3 (vcat (map fsep cycles))))
-topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
+  where
-topoSortJments2 (m,mi) = do
+    toNode (id,info,deps) = ((id,info),id,deps)
-  iss <- either
-           return
-           (\cyc -> raise (render ("circular definitions:"
-                                   <+> fsep (head cyc))))
-           (topoTest2 (allDependencies (==m) (jments mi)))
-  return
-    [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss]
-
 
 mkStrs p = case p of
  PAlt a b -> do

src/compiler/api/GF/Grammar/Parser.y

@@ -135,14 +135,14 @@ ModDef
                                           (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
                                       jments <- mapM (checkInfoType mtype) jments
                                       defs <- buildAnyTree id jments
-                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -253,19 +253,18 @@ CatDef
 
 FunDef :: { [(Ident,Info)] }
 FunDef
-  : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just []) (Just True)) | fun <- $2] } 
+  : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) (Just (0,[]))) | fun <- $2] }
 
 DefDef :: { [(Ident,Info)] }
 DefDef
-  : Posn LhsNames '=' Exp         Posn { [(f, AbsFun Nothing (Just 0)           (Just [mkL $1 $5 ([],$4)]) Nothing) | f <- $2] }
+  : Posn LhsNames '=' Exp            Posn { [(f, AbsFun Nothing (Just (0,[mkL $1 $5 ([],$4)]))) | f <- $2] }
-  | Posn LhsName ListPatt '=' Exp    Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]) Nothing)] }
+  | Posn LhsName ListPatt '=' Exp    Posn { [($2,AbsFun Nothing (Just (0,[mkL $1 $6 ($3,$5)])))] }
 
 DataDef :: { [(Ident,Info)] }
 DataDef
   : Posn Ident '=' ListDataConstr Posn { ($2,   AbsCat Nothing) :
-                                         [(fun, AbsFun Nothing Nothing Nothing  (Just True)) | fun <- $4] }
+                                         [(fun, AbsFun Nothing Nothing) | fun <- $4] }
-  | Posn ListIdent ':' Exp Posn        { -- (snd (valCat $4), AbsCat Nothing) :
+  | Posn ListIdent ':' Exp Posn        { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing) | fun <- $2] }
-                                         [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing (Just True)) | fun <- $2] }                                         
 
 ParamDef :: { [(Ident,Info)] }
 ParamDef
@@ -294,6 +293,9 @@ FlagDef
   : Posn Ident '=' Ident Posn  {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of
                                     Ok  x   -> return x
                                     Bad msg -> failLoc $1 msg                                           } 
+  | Posn Ident '=' String Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ $4] of
+                                    Ok  x   -> return x
+                                    Bad msg -> failLoc $1 msg                                           } 
   | Posn Ident '=' Double Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ show $4] of
                                     Ok  x   -> return x
                                     Bad msg -> failLoc $1 msg                                           } 
@@ -381,18 +383,20 @@ LhsNames
   : LhsName              { [$1]    }
   | LhsName ',' LhsNames { $1 : $3 }
 
-LocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+LocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
 LocDef
-  : ListIdent ':' Exp         { [(lab,Just $3,Nothing) | lab <- $1] } 
+  : '$' Ident ':' Exp         { [($2,True,Just $4,Nothing)] }
-  | ListIdent '=' Exp         { [(lab,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp         { [(lab,False,Just $3,Nothing) | lab <- $1] } 
-  | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
+  | ListIdent '=' Exp         { [(lab,False,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp '=' Exp { [(lab,False,Just $3,Just $5) | lab <- $1] }
 
-LocMarkupDef :: { [(Ident, Maybe Type, Maybe Term)] }
+LocMarkupDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
 LocMarkupDef
-  : ListIdent '=' Tag         { [(lab,Nothing,Just $3) | lab <- $1] }
+  : '$' Ident '=' Tag         { [($2,False,Nothing,Just $4)] }
-  | ListIdent ':' Exp '=' Tag { [(lab,Just $3,Just $5) | lab <- $1] }
+  | ListIdent '=' Tag         { [(lab,False,Nothing,Just $3) | lab <- $1] }
+  | ListIdent ':' Exp '=' Tag { [(lab,False,Just $3,Just $5) | lab <- $1] }
 
-ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] }
+ListLocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] }
 ListLocDef
   : {- empty -}             { []       }
   | LocDef                  { $1       }
@@ -443,8 +447,8 @@ Exp3
   | 'table' Exp6 '{' ListCase '}'    { T (TTyped $2) $4 }
   | 'table' Exp6 '[' ListExp ']'     { V $2 $4       }
   | Exp3 '*'  Exp4                   { case $1 of
-                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
+                                         RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),[],$3)])
-                                         t          -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)]  }
+                                         t          -> RecType [(tupleLabel 1,[],$1), (tupleLabel 2,[],$3)]  }
   | Exp3 '**' Exp4                   { ExtR $1 $3    }
   | Exp4                             { $1            }
 
@@ -479,9 +483,9 @@ Exp5
 
 Exp6 :: { Term }
 Exp6 
-  : Ident                 { Vr $1 } 
+  : Ident                 { Vr  $1 }
   | Sort                  { Sort $1 }
-  | String                { K $1 }
+  | String                { words2term (words $1) }
   | Integer               { EInt $1 }
   | Double                { EFloat $1 }
   | '?'                   { Meta 0 }
@@ -531,7 +535,7 @@ Patt3
   | '[' String ']'            { PChars $2 }
   | '#' Ident                 { PMacro $2 }
   | '#' ModuleName '.' Ident  { PM ($2,$4) }
-  | '_'                       { PW }
+  | '_'                       { PV identW }
   | Ident                     { PV $1 }
   | ModuleName '.' Ident      { PP ($1,$3) [] }
   | Integer                   { PInt $1 }
@@ -714,9 +718,11 @@ ERHS3 :: { ERHS }
   | '(' ERHS0 ')'         { $2         }
 
 NLG :: { Map.Map Ident Info }
-  : ListNLGDef             { Map.fromList $1 }
+  : ListNLGDef            { Map.fromList $1 }
-  | Posn Exp         Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
+  | Posn Exp Posn         { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
-  | Posn ListMarkup2 Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (mkMarkup $2)))) }
+  | ListMarkup2           { case (head $1,last $1) of
+                              (L (Local l1 _) _, L (Local _ l2) _) -> Map.singleton (identS "main") (ResOper Nothing (Just (L (Local l1 l2) (mkMarkup $1))))
+                          }
 
 ListNLGDef :: { [(Ident,Info)] }
 ListNLGDef
@@ -730,10 +736,10 @@ NLGDef
   | Posn LhsName ListArg '=' ListMarkup2  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 (mkMarkup $5))))] }
   | Posn LhsNames ':' Exp '=' ListMarkup2 Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 (mkMarkup $6)))] }
 
-Markup :: { Term }
+Markup :: { L Term }
 Markup
-  : Tag     { $1 }
+  : Posn Tag Posn     { mkL $1 $3 $2 }
-  | Exp ';' { $1 }
+  | Posn Exp Posn ';' { mkL $1 $3 $2 }
 
 Tag :: { Term }
 Tag
@@ -742,12 +748,12 @@ Tag
                                                        else fail ("Unmatched closing tag " ++ showIdent $1) }
   | '<tag' Attributes '/' '>'                     { Markup $1 $2 [] }
 
-ListMarkup :: { [Term] }
+ListMarkup :: { [L Term] }
   :                    { []      }
-  | Exp                { [$1]    }
+  | Posn Exp Posn      { [mkL $1 $3 $2] }
   | Markup ListMarkup  { $1 : $2 }
 
-ListMarkup2 :: { [Term] }
+ListMarkup2 :: { [L Term] }
   : Markup              { [$1]    }
   | Markup ListMarkup2  { $1 : $2 }
 
@@ -790,8 +796,8 @@ listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
     consId = mkConsId id
 
     catd     = (listId, AbsCat (Just (L loc cont')))
-    nilfund  = (baseId, AbsFun (Just (L loc niltyp))  Nothing Nothing (Just True))
+    nilfund  = (baseId, AbsFun (Just (L loc niltyp))  Nothing)
-    consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing (Just True))
+    consfund = (consId, AbsFun (Just (L loc constyp)) Nothing)
 
     cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
     xs = map (\(b,x,t) -> Vr x) cont'
@@ -803,20 +809,23 @@ listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
 
     mkId x i = if x == identW then (varX i) else x
 
-tryLoc (c,mty,Just e) = return (c,(mty,e))
+tryLoc (c,False,mty,Just e) = return (c,(mty,e))
-tryLoc (c,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
+tryLoc (c,True ,_  ,_     ) = fail ("Scoped record label " +++ showIdent c +++ "outside of a record")
+tryLoc (c,_    ,_  ,_     ) = fail ("local definition of" +++ showIdent c +++ "without value")
 
 mkR []       = return $ RecType [] --- empty record always interpreted as record type
 mkR fs@(f:_) =
   case f of
-    (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
+    (lab,_,Just ty,Nothing) ->   tryRT [] fs >>= return . RecType
-    _                     -> mapM tryR  fs >>= return . R
+    _                       -> mapM tryR  fs >>= return . R
   where
-    tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
+    tryRT deps []                                = return []
-    tryRT (lab,_      ,_      ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
+    tryRT deps ((lab,scoped,Just ty,Nothing):fs) = do fs <- tryRT (if scoped then lab:deps else deps) fs
+                                                      return ((ident2label lab,deps,ty):fs)
+    tryRT deps ((lab,_     ,_      ,_      ):fs) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
 
-    tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
+    tryR (lab,False,mty,Just t) = return (ident2label lab,(mty,t))
-    tryR (lab,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
+    tryR (lab,_    ,_  ,_     ) = fail $ "illegal record field" +++ showIdent lab
 
 mkOverload pdt pdf@(Just (L loc df)) =
   case appForm df of
@@ -844,12 +853,12 @@ isOverloading t =
 checkInfoType mt jment@(id,info) =
   case info of
     AbsCat pcont         -> ifAbstract mt (locPerh pcont)
-    AbsFun pty _ pde _   -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
+    AbsFun pty pde       -> ifAbstract mt (locPerh pty ++ maybe [] (locAll.snd) pde)
     CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
     CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
     ResParam pparam _    -> ifResource mt (locPerh pparam)
     ResValue ty _        -> ifResource mt (locL ty)
-    ResOper  pty pt      -> ifOper mt pty pt
+    ResOper  pty pt      -> ifResource mt (locPerh pty ++ locPerh pt)
     ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where
     locPerh = maybe [] locL
@@ -870,9 +879,6 @@ checkInfoType mt jment@(id,info) =
     ifResource MTInterface    locs = return jment
     ifResource MTResource     locs = return jment
     ifResource _              locs = illegal locs
-    
-    ifOper MTAbstract pty pt = return (id,AbsFun pty (fmap (const 0) pt) (Just (maybe [] (\(L l t) -> [L l ([],t)]) pt)) (Just False))
-    ifOper _          pty pt = return jment
 
 mkAlts cs = case cs of
   _:_ -> do
@@ -889,7 +895,11 @@ mkAlts cs = case cs of
 mkL :: Posn -> Posn -> x -> L x
 mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
 
-mkMarkup [t] = t
+mkMarkup [t] = unLoc t
 mkMarkup ts  = Markup identW [] ts
 
+words2term []     = Empty
+words2term [w]    = K w
+words2term (w:ws) = C (K w) (words2term ws)
+
 }

src/compiler/api/GF/Grammar/Predef.hs

@@ -25,6 +25,7 @@ cFloat = identS "Float"
 cString = identS "String"
 cInts = identS "Ints"
 cPBool = identS "PBool"
+cBool = identS "Bool"
 cErrorType = identS "Error"
 cOverload = identS "overload"
 cNonExist = identS "nonExist"
@@ -40,6 +41,8 @@ isPredefCat c = elem c [cInt,cString,cFloat]
 
 cPTrue  = identS "PTrue"
 cPFalse = identS "PFalse"
+cTrue  = identS "True"
+cFalse = identS "False"
 cLength = identS "length"
 cDrop = identS "drop"
 cTake = identS "take"
@@ -66,23 +69,11 @@ cConcat = identS "concat"
 cConcat' = identS "concat'"
 cOne = identS "one"
 cSelect = identS "select"
+cFilter = identS "filter"
 cDefault = identS "default"
 cList = identS "list"
 cLen = identS "len"
+cConst = identS "const"
 
 cp1 = identS "p1"
 cp2 = identS "p2"
-
--- * Hacks: dummy identifiers used in various places.
--- Not very nice!
-
-cMeta = identS "?"
-cAs = identS "@"
-cChar = identS "?"
-cChars = identS "[]"
-cSeq = identS "+"
-cAlt = identS "|"
-cRep = identS "*"
-cNeg = identS "-"
-cCNC = identS "CNC"
-cConflict = identS "#conflict"

src/compiler/api/GF/Grammar/Printer.hs

@@ -16,26 +16,23 @@ module GF.Grammar.Printer
            , ppParams
            , ppTerm
            , ppPatt
-           , ppValue
            , ppBind
-           , ppConstrs
            , ppQIdent
            , ppMeta
+           , ppLVar
            , getAbs
            ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import PGF2(Literal(..),pgfFilePath)
-import PGF2.Transactions(SeqId)
 import GF.Infra.Ident
 import GF.Infra.Option
-import GF.Grammar.Values
 import GF.Grammar.Predef
 import GF.Grammar.Grammar
 
 import GF.Text.Pretty
 import Data.Maybe (isNothing)
-import Data.List  (intersperse)
+import Data.List  (intersperse, nub)
 import Data.Foldable (toList)
 import qualified Data.Map as Map
 import qualified Data.Sequence as Seq
@@ -49,11 +46,10 @@ instance Pretty Grammar where
   pp = vcat . map (ppModule Qualified) . modules
 
 ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
     hdr $$
     nest 2 (ppOptions opts $$
-            vcat (map (ppJudgement q) (Map.toList jments)) $$
+            vcat (map (ppJudgement q) (Map.toList jments))) $$
-            maybe empty (ppSequences q) mseqs) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -92,22 +88,21 @@ ppOptions opts =
   "flags" $$
   nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
 
-ppJudgement q (id, AbsCat pcont ) =
+ppJudgement q (id, AbsCat pcont) =
   "cat" <+> id <+>
   (case pcont of
      Just (L _ cont) -> hsep (map (ppDecl q) cont)
      Nothing         -> empty) <+> ';'
-ppJudgement q (id, AbsFun ptype _ pexp poper) =
+ppJudgement q (id, AbsFun ptype pexp) =
   let kind | isNothing pexp      = "data"
-           | poper == Just False = "oper"
            | otherwise           = "fun"
   in
   (case ptype of
      Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
      Nothing        -> empty) $$
   (case pexp of
-     Just []  -> empty
+     Just (_,[])  -> empty
-     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
+     Just (_,eqs) -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
      Nothing  -> empty)
 ppJudgement q (id, ResParam pparams _) =
   "param" <+> id <+>
@@ -142,9 +137,9 @@ ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
      Nothing        -> empty) $$
   (case (mtyp,mpmcfg,q) of
      (Just (L _ typ),Just (lindefs,linrefs),Internal)
-                    -> "pmcfg" <+> '{' $$
+                    -> "rules" <+> '{' $$
-                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)  $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)) $$
-                               vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
+                       nest 2 (vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
@@ -157,7 +152,7 @@ ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
      Nothing        -> empty) $$
   (case (mtyp,mpmcfg,q) of
      (Just (args,res,_,_),Just rules,Internal)
-                    -> "pmcfg" <+> '{' $$
+                    -> "rules" <+> '{' $$
                        nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
                        '}'
      _              -> empty)
@@ -166,20 +161,22 @@ ppJudgement q (id, AnyInd cann mid) =
     Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
     _        -> empty
 
-ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) =
-  pp id <+> (':' <+>
-             (if null vars
-                then empty
-                else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}'  <+> '.') <+>
-             ppPmcfgCat res_cat res <+> "->" <+>
-             brackets (hcat (intersperse (pp ',') (zipWith ppPArg arg_cats args))) <+> '=' <+> 
-             brackets (hcat (intersperse (pp ',') (map ppSeqId seqids))))
-
 ppPArg cat (PArg _ p) = ppPmcfgCat cat p
 
 ppPmcfgCat :: Ident -> LParam -> Doc
 ppPmcfgCat cat p = pp cat <> parens (ppLParam p)
 
+ppPmcfgRule id arg_cats res_cat (Rule quantifiers res args lin_idx seq) =
+  ppQuantifiers (zip [0..] quantifiers) <+>
+  ppCat res_cat res <+> "->" <+> pp id <> brackets (hcat (punctuate ',' (zipWith ppCat arg_cats args))) <> ';' <+> ppLParam lin_idx <+> ':' <+> hsep (map ppSymbol seq)
+  where
+    ppCat id value = pp id <> parens (ppLParam value)
+
+    ppQuantifiers [] = empty
+    ppQuantifiers qs = pp '{' <> hsep (punctuate (pp ',') (map ppQuantifier qs)) <> pp '}'
+
+    ppQuantifier (var,range) = ppLVar var <> pp '<' <> pp (range::Int)
+
 instance Pretty Term where pp = ppTerm Unqualified 0
 
 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
@@ -244,12 +241,13 @@ ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+>
                                                        fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
                                                              '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
 ppTerm q d (RecType xs)
-  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
+  | q == Terse         = case [cat | (l,_,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
                            [cat] -> pp cat
                            _     -> doc
   | otherwise          = doc
   where
-    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+    deps = nub [ident2label dep | (_,deps,_) <- xs, dep <- deps]
+    doc  = braces (fsep (punctuate ';' [(if l `elem` deps then pp '$' else empty) <> l <+> ':' <+> ppTerm q 0 t | (l,bound,t) <- xs]))
 ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
 ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
@@ -294,7 +292,6 @@ ppPatt q d (PChar)      = pp '?'
 ppPatt q d (PChars s)   = brackets (str s)
 ppPatt q d (PMacro id)  = '#' <> id
 ppPatt q d (PM id)      = '#' <> ppQIdent q id
-ppPatt q d PW           = pp '_'
 ppPatt q d (PV id)      = pp id
 ppPatt q d (PInt n)     = pp n
 ppPatt q d (PFloat f)   = pp f
@@ -303,22 +300,6 @@ ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0
 ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
 ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
 
-ppValue :: TermPrintQual -> Int -> Val -> Doc
-ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging
-ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
-ppValue q d (VCn (_,c))   = pp c
-ppValue q d (VClos env e) = case e of
-                              Meta _ -> ppTerm q d e <> ppEnv env
-                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
-ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
-ppValue q d VType         = pp "Type"
-
-ppConstrs :: Constraints -> [Doc]
-ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
-
-ppEnv :: Env -> Doc
-ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
-
 str s = doubleQuotes (pp (foldr showLitChar "" s))
   where
     showLitChar c
@@ -326,13 +307,9 @@ str s = doubleQuotes (pp (foldr showLitChar "" s))
       | c > '\DEL'  = showChar c
       | otherwise   = GHC.Show.showLitChar c
 
-ppDecl q (_,id,typ)
+ppDecl q (bt,id,typ)
-  | id == identW = ppTerm q 3 typ
+  | id == identW = ppTerm q 5 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+  | otherwise    = parens (ppBind (bt,id) <+> ':' <+> ppTerm q 0 typ)
-
-ppDDecl q (_,id,typ)
-  | id == identW = ppTerm q 6 typ
-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
 
 ppQIdent :: TermPrintQual -> QIdent -> Doc
 ppQIdent q (m,id) =
@@ -360,30 +337,18 @@ ppBind (Implicit,v) = braces v
 ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 
 ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
+ppParam q (id,cxt) = id <+> hsep (map (ppDecl q) cxt)
 
 ppMarkupAttr q (id,e) =
   id <> pp '=' <> ppTerm q 5 e
 
-ppMarkupChildren q [t]    = ppTerm q 0 t
+ppMarkupChildren q [L _ t]    = ppTerm q 0 t
-ppMarkupChildren q (t:ts) =
+ppMarkupChildren q (L _ t:ts) =
   (case t of
      Markup {} -> ppTerm q 0 t
      _         -> ppTerm q 0 t <> ';') $$
   ppMarkupChildren q ts
 
-ppSeqId :: SeqId -> Doc
-ppSeqId seqid = 'S' <> pp seqid
-
-ppSequences q seqs
-  | Seq.null seqs || q /= Internal = empty
-  | otherwise                      = "sequences" <+> '{' $$
-                                     nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$
-                                    '}'
-  where
-    ppSeq seqid seq =
-      ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq)
-
 commaPunct f ds = (hcat (punctuate "," (map f ds)))
 
 prec d1 d2 doc
@@ -398,8 +363,6 @@ getAbs e            = ([],e)
 getCTable :: Term -> ([Ident], Term)
 getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
                                 in (v:vs,e')
-getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e
-                                in (identW:vs,e')
 getCTable e                   = ([],e)
 
 getLet :: Term -> ([LocalDef], Term)
@@ -417,7 +380,6 @@ ppLit (LInt n) = pp n
 ppLit (LFlt d) = pp d
 
 ppSymbol (SymCat d r)= pp '<' <> pp d <> pp ',' <> ppLParam r <> pp '>'
-ppSymbol (SymLit d r)= pp '{' <> pp d <> pp ',' <> ppLParam r <> pp '}'
 ppSymbol (SymVar d r)   = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
 ppSymbol (SymKS t)      = doubleQuotes (pp t)
 ppSymbol SymNE          = pp "nonExist"

src/compiler/api/GF/Grammar/Unify.hs

@@ -1,115 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Unify
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:31 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.4 $
---
--- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
---
--- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
--- the only use is in 'TypeCheck.splitConstraints'
------------------------------------------------------------------------------
-
-module GF.Grammar.Unify (unifyVal) where
-
-import GF.Grammar
-import GF.Data.Operations
-
-import GF.Text.Pretty
-import Data.List (partition)
-
-unifyVal :: Constraints -> Err (Constraints,MetaSubst)
-unifyVal cs0 = do
-  let (cs1,cs2) = partition notSolvable cs0 
-  let (us,vs) = unzip cs2
-  let us' = map val2term us
-  let vs' = map val2term vs
-  let (ms,cs) = unifyAll (zip us' vs') []
-  return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], 
-          [(m,          VClos [] t) | (m,t) <- ms])
- where
-   notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
-     (VClos (_:_) _,_) -> True
-     (_,VClos (_:_) _) -> True
-     _ -> False
-
-type Unifier = [(MetaId, Term)]
-type Constrs = [(Term, Term)]
-
-unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
-unifyAll [] g = (g, [])
-unifyAll ((a@(s, t)) : l) g =
-  let (g1, c) = unifyAll l g
-  in case unify s t g1 of
-       Ok g2  -> (g2, c)
-       _      -> (g1, a : c)
-
-unify :: Term -> Term -> Unifier -> Err Unifier
-unify e1 e2 g = 
- case (e1, e2) of 
-  (Meta s, t) -> do
-     tg <- subst_all g t
-     let sg = maybe e1 id (lookup s g)
-     if (sg == Meta s) then extend g s tg else unify sg tg g 
-  (t, Meta s) -> unify e2 e1 g
-  (Q (_,a), Q (_,b)) | (a == b)  -> return g ---- qualif?
-  (QC (_,a), QC (_,b)) | (a == b)-> return g ----
-  (Vr x, Vr y) | (x == y)        -> return g 
-  (Abs _ x b, Abs _ y c)         -> do let c' = substTerm [x] [(y,Vr x)] c 
-                                       unify b c' g
-  (App c a, App d b)            -> case unify c d g of 
-                                     Ok g1 -> unify a b g1 
-                                     _     -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1))
-  (RecType xs,RecType ys) | xs == ys -> return g
-  _                             -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1))
-
-extend :: Unifier -> MetaId -> Term -> Err Unifier
-extend g s t | (t == Meta s) = return g  
-             | occCheck s t  = Bad (render ("occurs check" <+> ppTerm Unqualified 0 t))
-             | True          = return ((s, t) : g) 
-
-subst_all :: Unifier -> Term -> Err Term
-subst_all s u =
- case (s,u) of
-  ([], t)  -> return t
-  (a : l, t) -> do
-     t' <- (subst_all l t) --- successive substs - why ?
-     return $ substMetas [a] t'
-
-substMetas :: [(MetaId,Term)] -> Term -> Term
-substMetas subst trm = case trm of
-   Meta x -> case lookup x subst of
-     Just t -> t
-     _ -> trm
-   _ -> composSafeOp (substMetas subst) trm
-
-substTerm  :: [Ident] -> Substitution -> Term -> Term
-substTerm ss g c = case c of
-  Vr x        -> maybe c id $ lookup x g
-  App f a     -> App (substTerm ss g f) (substTerm ss g a)
-  Abs b x t   -> let y = mkFreshVarX ss x in 
-                   Abs b y (substTerm (y:ss) ((x, Vr y):g) t)
-  Prod b x a t  -> let y = mkFreshVarX ss x in 
-                   Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t)
-  _           -> c
-
-occCheck :: MetaId -> Term -> Bool
-occCheck s u = case u of
-    Meta v  -> s == v
-    App c a -> occCheck s c || occCheck s a
-    Abs _ x b -> occCheck s b
-    _       -> False
-
-val2term :: Val -> Term
-val2term v = case v of
-  VClos g e   -> substTerm [] (map (\(x,v) -> (x,val2term v)) g) e
-  VApp f c    -> App (val2term f) (val2term c)
-  VCn c       -> Q c
-  VGen i x    -> Vr x
-  VRecType xs -> RecType (map (\(l,v) -> (l,val2term v)) xs)
-  VType       -> typeType

src/compiler/api/GF/Grammar/Values.hs

@@ -1,57 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Values
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:32 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.7 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Grammar.Values (
-               -- ** Values used in TC type checking
-               Val(..), Env,
-               -- ** Annotated tree used in editing
-               Binds, Constraints, MetaSubst,
-               -- ** For TC
-               valAbsInt, valAbsFloat, valAbsString, vType,
-               isPredefCat,
-               eType,
-              ) where
-
-import GF.Infra.Ident
-import GF.Grammar.Grammar
-import GF.Grammar.Predef
-
--- values used in TC type checking
-
-data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | VType | VClos Env Term
-  deriving (Eq,Show)
-
-type Env = [(Ident,Val)]
-
-type Binds = [(Ident,Val)]
-type Constraints = [(Val,Val)]
-type MetaSubst = [(MetaId,Val)]
-
-
--- for TC
-
-valAbsInt :: Val
-valAbsInt = VCn (cPredefAbs, cInt)
-
-valAbsFloat :: Val
-valAbsFloat = VCn (cPredefAbs, cFloat)
-
-valAbsString :: Val
-valAbsString = VCn (cPredefAbs, cString)
-
-vType :: Val
-vType = VType
-
-eType :: Term
-eType = Sort cType

src/compiler/api/GF/Infra/Ident.hs

@@ -26,10 +26,10 @@ module GF.Infra.Ident (-- ** Identifiers
 ) where
 
 import qualified Data.ByteString.UTF8 as UTF8
-import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
+import qualified Data.ByteString.Char8 as BS(append,isPrefixOf,drop,length)
                  -- Limit use of BS functions to the ones that work correctly on
                  -- UTF-8-encoded bytestrings!
-import Data.Char(isDigit)
+import Data.Char(chr)
 import Data.Binary(Binary(..))
 import Text.JSON hiding (Result(..))
 import GF.Text.Pretty
@@ -75,7 +75,9 @@ rawIdentC = Id
 showRawIdent = unpack . rawId2utf8
 
 prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
-isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
+isPrefixOf (Id x) (Id y)
+ | BS.isPrefixOf x y = Just (Id (BS.drop (BS.length x) y))
+ | otherwise         = Nothing
 
 instance Binary Ident where
   put id = put (ident2utf8 id)
@@ -102,7 +104,26 @@ ident2raw = Id . ident2utf8
 showIdent :: Ident -> String
 showIdent i = unpack $! ident2utf8 i
 
-instance Pretty Ident where pp = pp . showIdent
+instance Pretty Ident where
+  pp id
+    | valid_ident s = pp s
+    | otherwise     = pp (escape s)
+    where
+      s = showIdent id
+
+      valid_ident s =
+        case s of
+          [] -> False
+          (c:cs) -> elem c ident_first && all (flip elem ident_rest) cs
+        where
+          l = ['a'..'z']++['A'..'Z']++[chr 192..chr 214]++[chr 216..chr 246]++[chr 248..chr 255]
+          ident_first = '_':l
+          ident_rest  = ident_first ++ ['0'..'9'] ++ ['\'']
+
+      escape s = "\'"++concatMap slash s++"\'"
+        where
+          slash '\'' = "\\'"
+          slash c    = [c]
 
 instance Pretty RawIdent where pp = pp . showRawIdent
 

src/compiler/api/GF/Infra/Location.hs

@@ -14,10 +14,14 @@ data Location
   deriving (Show,Eq,Ord)
 
 -- | Attaching location information
-data L a = L Location a deriving Show
+data L a = L Location a deriving (Show, Eq, Ord)
 
 instance Functor L where fmap f (L loc x) = L loc (f x)
 
+instance Foldable L where foldr f b (L loc x) = f x b
+
+instance Traversable L where traverse f (L loc x) = pure (L loc) <*> f x
+
 unLoc :: L a -> a
 unLoc (L _ x) = x
 

src/compiler/api/GF/Infra/Option.hs

@@ -107,7 +107,6 @@ data OutputFormat = FmtPGFPretty
                   | FmtSLF
                   | FmtRegExp
                   | FmtFA
-                  | FmtLR
   deriving (Eq,Ord)
 
 data SISRFormat =
@@ -492,8 +491,7 @@ outputFormatsExpl =
      (("vxml",         FmtVoiceXML),"Voice XML based on abstract syntax"),
      (("slf",          FmtSLF),"SLF speech recognition format"),
      (("regexp",       FmtRegExp),"regular expression"),
-     (("fa",           FmtFA),"finite automaton in graphviz format"),
+     (("fa",           FmtFA),"finite automaton in graphviz format")
-     (("lr",           FmtLR),"LR(0) automaton for PMCFG in graphviz format")
      ]
 
 instance Show OutputFormat where

src/compiler/api/GF/Interactive.hs

@@ -13,9 +13,8 @@ import GF.Command.Help(helpCommand)
 import GF.Command.Abstract
 import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand)
 import GF.Compile.Rename(renameSourceTerm)
-import GF.Compile.TypeCheck.Concrete(inferLType)
+import GF.Compile.TypeCheck(inferLType)
-import qualified GF.Compile.Compute.Concrete as O(normalForm,stdPredef,Globals(..))
+import GF.Compile.Compute(stdPredef,normalForm,Globals(..))
-import GF.Compile.Compute.Concrete2(stdPredef,Globals(..))
 import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields)
 import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)
@@ -301,9 +300,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
            mb_fields <- getCategoryFields cat
            case mb_fields of
              Just fields -> case runCheck (compileLinTerm sgr mo f mb_t (type2term mo ty)) of
-                              Ok ((prods,seqtbl,fields'),_)
+                              Ok ((rules,fields'),_)
                                    | fields == fields' -> do
-                                       (if is_alter then alterLin else createLin) f prods seqtbl
+                                       (if is_alter then alterLin else createLin) f rules
                                        return ()
                                    | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
                               Bad msg      -> fail msg
@@ -316,21 +315,20 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do
             hypos
 
     compileLinTerm sgr mo f mb_t ty = do
+      let g = Gl sgr (stdPredef g) False
       (t,ty) <- case mb_t of
                   Just t  -> do t <- renameSourceTerm sgr mo (Typed t ty)
-                                let g = Gl sgr (stdPredef g)
+                                
                                 (t,ty) <- inferLType g t
                                 return (t,ty)
                   Nothing -> case lookupResDef sgr (mo,identS f) of
                                Ok t    -> do ty <- renameSourceTerm sgr mo ty
-                                             ty <- O.normalForm (O.Gl sgr O.stdPredef) ty
+                                             ty <- normalForm g ty
                                              return (t,ty)
                                Bad msg -> fail msg
       let (ctxt,res_ty) = typeFormCnc ty
-      (prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty
+      rules <- pmcfgForm g t ctxt res_ty
-      return (prods,mapToSequence seqs,type2fields sgr res_ty)
+      return (rules,type2fields sgr res_ty)
-      where
-        mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
 
 transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
   sgr <- getGrammar
@@ -339,14 +337,14 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do
           Just mo -> return mo
   lang <- optLang pgf opts
   case runCheck (compileLincatTerm sgr mo mb_t) of
-    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
+    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] >> return ()))
                        return ()
     Bad msg      -> fail msg
   where
     compileLincatTerm sgr mo mb_t = do
       t <- case mb_t of
              Just t  -> do t <- renameSourceTerm sgr mo t
-                           let g = Gl sgr (stdPredef g)
+                           let g = Gl sgr (stdPredef g) False
                            (t,_) <- inferLType g t
                            return t
              Nothing -> case lookupResDef sgr (mo,identS c) of

src/compiler/api/GF/Server/PGFService.hs

@@ -144,7 +144,7 @@ pgfCommand qsem command q (t,pgf) =
 
     -- Without caching parse results:
     parse' cat start mlimit ((from,concr),input) =
-        case PGF2.parse concr cat (init input) of
+        case PGF2.parse concr cat input of
           ParseOk ts        -> return (Right (maybe id take mlimit (drop start ts)))
           ParseFailed _ tok -> return (Left tok)
           ParseIncomplete   -> return (Left "")

src/compiler/api/GF/Server/SimpleEditor/Convert.hs

@@ -70,7 +70,7 @@ convAbsJment (cats,funs) (name,jment) =
                              fail "category with context"
                       let cat = convId name
                       return (cat:cats,funs)
-    AbsFun (Just lt) _ oeqns _ -> do unless (null (maybe [] id oeqns)) $
+    AbsFun (Just lt) oeqns     -> do unless (null (maybe [] snd oeqns)) $
                                             fail "function with equations"
                                      let f = convId name
                                      typ <- convType (unLoc lt)
@@ -150,7 +150,7 @@ jmentList = sortBy (compare `on` (jmentLocation.snd)) . Map.toList
 jmentLocation jment =
   case jment of
     AbsCat ctxt      -> fmap loc ctxt
-    AbsFun ty _ _ _  -> fmap loc ty
+    AbsFun ty _      -> fmap loc ty
     ResParam ops _   -> fmap loc ops
     CncCat ty _ _ _ _ ->fmap loc ty
     ResOper ty rhs   -> fmap loc rhs `mplus` fmap loc ty

src/compiler/api/GF/Speech/CFGToFA.hs

@@ -20,7 +20,6 @@ import GF.Grammar.CFG
 --import GF.Infra.Ident (Ident)
 
 import GF.Data.Graph
---import GF.Data.Relation
 import GF.Speech.FiniteState
 --import GF.Speech.CFG
 

src/compiler/api/GF/Term.hs

@@ -1,12 +0,0 @@
-module GF.Term (renameSourceTerm,
-                Globals(..), ConstValue(..), EvalM, stdPredef,
-                Value(..), showValue, Thunk, newThunk, newEvaluatedThunk,
-                evalError, evalWarn,
-                inferLType, inferLType', checkLType, checkLType',
-                normalForm, normalFlatForm, normalStringForm,
-                unsafeIOToEvalM, force
-               ) where
-
-import GF.Compile.Rename
-import GF.Compile.Compute.Concrete
-import GF.Compile.TypeCheck.Concrete

src/compiler/gf.cabal

@@ -76,7 +76,6 @@ library
     GF.Interactive
     GF.Compiler
     GF.Grammar
-    GF.Term
     GF.Compile
     GF.CompileInParallel
     GF.Data.ErrM
@@ -105,8 +104,7 @@ library
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Concrete
+    GF.Compile.Compute
-    GF.Compile.Compute.Concrete2
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
@@ -124,9 +122,8 @@ library
     GF.Compile.SubExOpt
     GF.Compile.Tags
     GF.Compile.ToAPI
-    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck
-    GF.Compile.TypeCheck.Concrete
+    GF.Compile.TerminationCheck
-    GF.Compile.TypeCheck.TC
     GF.Compile.Update
     GF.Data.BacktrackM
     GF.Data.Graph
@@ -149,8 +146,6 @@ library
     GF.Grammar.Predef
     GF.Grammar.Printer
     GF.Grammar.ShowTerm
-    GF.Grammar.Unify
-    GF.Grammar.Values
     GF.Grammar.JSON
     GF.Infra.Concurrency
     GF.Infra.Dependencies

src/compiler/www/gfse/editor.js

@@ -1172,12 +1172,10 @@ function add_open(g,ci) {
 	    var b=common_modules[i];
 	    add_module(b,b)
 	}
-	if (gfwordnet.languages.indexOf("Parse"+conc.langcode) >= 0) {
+    for(var i in wordnet_modules) {
-		for(var i in wordnet_modules) {
+        var b=wordnet_modules[i];
-			var b=wordnet_modules[i];
+        add_module(b,b+conc.langcode)
-			add_module(b,b+conc.langcode)
+    }
-		}
-	}
 	if(list.length>0) {
 	    var file=element("file");
 	    clear(file)
@@ -1477,9 +1475,6 @@ function wordnet_search(g,input) {
 		langs: {},
 		langs_list: []
 	};
-	if (gfwordnet.languages.indexOf(selection.current) < 0) {
-		return;
-	}
 	var start = input.selectionStart;
 	var end   = input.selectionEnd;
 	if (start == end) {
@@ -1517,11 +1512,9 @@ function wordnet_search(g,input) {
 	for (var i=0; i < g.concretes.length; i++) {
 		var code = g.concretes[i].langcode;
 		var name = "Parse"+code;
-		if (gfwordnet.languages.indexOf(name) >= 0) {
+        selection.langs[name] = {name: langname[code], index: index};
-			selection.langs[name] = {name: langname[code], index: index};
+        selection.langs_list.push(name);
-			selection.langs_list.push(name);
+        index++;
-			index++;
-		}
 	}
 	selection.isEqual = function(other) {
 		if (other.langs_list.length != this.langs_list.length)

src/compiler/www/js/gftranslate.js

@@ -7,8 +7,9 @@ gftranslate.jsonurl="/robust/Parse.ngf"
 gftranslate.grammar="Parse" // the name of the grammar
 
 gftranslate.documented_classes=
-    ["N", "N2", "N3", "A", "A2", "V", "V2", "VV", "VS", "VQ", "VA", "V3", "V2V",
+    ["N", "N2", "N3", "PN", "LN", "GN", "SN", "A", "A2",
-     "V2S", "V2Q", "V2A", "Adv", "Prep"]
+     "V", "V2", "VV", "VS", "VQ", "VA", "V3", "V2V",
+     "V2S", "V2Q", "V2A", "Adv", "AdV", "AdA", "AdN", "Prep"]
 
 gftranslate.call=function(querystring,cont,errcont) {
     http_get_json(gftranslate.jsonurl+querystring,cont,errcont)
@@ -99,7 +100,7 @@ gftranslate.get_languages=function(cont,errcont) {
     else {
 	gftranslate.waiting.push({cont:cont,errcont:errcont})
 	if(gftranslate.waiting.length<2) 
-	    gftranslate.call("?command=grammar",init2,init2error)
+	    gftranslate.call("",init2,init2error)
     }
 }
 

src/compiler/www/js/langcode.js

@@ -16,16 +16,21 @@ var languages =
 	}
 	var ls
 	//  [ISO-639-2 code "/"] language name ":" ISO 639-1 code
-	ls=["Afrikaans:af","Amharic:am","Arabic:ar","Bulgarian:bg","Catalan:ca",
+    ls=["Afrikaans:af","Sqi/Albanian:sq","Amharic:am","Arabic:ar",
-	    "Chinese:zh","Czech:cs","Danish:da","Dutch:nl","English:en",
+        "Hye/Armenian:hy","Eus/Basque/eu","Bel/Belarusian:be","Bulgarian:bg",
-	    "Estonian:et","Finnish:fi","French:fr","German:de","Greek:el",
+        "Catalan:ca","Chinese:zh","Czech:cs","Danish:da",
-	    "Hebrew:he","Hindi:hi","Ina/Interlingua:ia",
+        "Dutch:nl","English:en","Estonian:et","Fao/Faroese:fo",
-	    "Icelandic:is","Gle/Irish:ga","Italian:it","Jpn/Japanese:ja",
+        "Finnish:fi","French:fr","Gla/Gaelic:gd","German:de",
-	    "Latin:la","Lav/Latvian:lv","Mlt/Maltese:mt","Mongolian:mn",
+        "Greek:el","Hebrew:he","Hindi:hi","Hungarian:hu",
-	    "Nepali:ne","Norwegian:nb","Pes/Persian:fa","Polish:pl",
+        "Icelandic:is","Ina/Interlingua:ia","Gle/Irish:ga","Italian:it",
-	    "Portuguese:pt","Pnb/Punjabi:pa",
+        "Jpn/Japanese:ja","Kazakh:kk","Korean:ko","Latin:la",
-	    "Ron/Romanian:ro","Russian:ru","Snd/Sindhi:sd","Spanish:es",
+        "Lav/Latvian:lv","Mkd/Macedonian:mk","Mlt/Maltese:mt","Mongolian:mn",
-	    "Swedish:sv","Thai:th","Turkish:tr","Urdu:ur"]
+        "Nepali:ne","Norwegian Bokmål:nb","Nno/Norwegian Nynorsk:nn","Pes/Persian:fa",
+        "Polish:pl","Portuguese:pt","Pnb/Punjabi:pa","Ron/Romanian:ro",
+        "Russian:ru","Scots:sco","Slv/Slovenian:sl","Somali:so",
+        "Snd/Sindhi:sd","Spanish:es","Swahili:sw","Swedish:sv",
+        "Thai:th","Turkish:tr","Ukrainian:uk","Urdu:ur",
+        "Zulu:zu"]
 	// GF uses nonstd 3-letter codes? Pes/Persian:fa, Pnb/Punjabi:pa
 	return map(lang1,ls)
     }()

src/compiler/www/js/wc.js

@@ -2,8 +2,6 @@
 /* --- Wide Coverage Translation Demo web app ------------------------------- */
 
 var wc={}
-wc.selected_cnls=[] // list of grammar names
-wc.cnls={} // maps grammars names to {pgf_online:...,grammar_info:{...}}
 wc.f=document.forms[0]
 wc.o=element("output")
 wc.e=element("extra")
@@ -44,7 +42,6 @@ wc.save=function() {
 	wc.local.put("to",f.to.value)
 	wc.local.put("input",f.input.value)
 	wc.local.put("colors",f.colors.checked)
-	wc.local.put("cnls",wc.selected_cnls)
     }
 }
 
@@ -55,7 +52,6 @@ wc.load=function() {
 	f.from.value=wc.local.get("from",f.from.value)
 	f.to.value=wc.local.get("to",f.to.value)
 	f.colors.checked=wc.local.get("colors",f.colors.checked)
-	wc.selected_cnls=wc.local.get("cnls",wc.selected_cnls)
 	wc.colors()
 	wc.delayed_translate()
     }
@@ -125,13 +121,19 @@ wc.translate=function(redo) {
 		function show_inflections(lins) {
 		    if(wc.e2) wc.e2.innerHTML=lins[0].text
 		}
-		function get_inflections() {
+		function get_inflections(glosses) {
-		    var tree="MkDocument+%22%22+(Inflection"+wcls+"+"+w+")+%22%22"
+            if (glosses.length == 0) {
+                glosses = [""]
+            }
+		    var tree="MkDocument+(NoDefinition+%22"+glosses[0]+"%22)+(Inflection"+wcls+"+"+w+")+%22%22"
 		    var l=gftranslate.grammar+f.to.value
-		    gftranslate.call("?command=c-linearize&to="+l+"&tree="+tree,show_inflections)
+		    gftranslate.call("?command=linearize&to="+l+"&tree="+tree,show_inflections)
 		}
+        function get_gloss() {
+            ajax_http_post_querystring_json("https://cloud.grammaticalframework.org/wordnet/SenseService.fcgi","gloss_id="+w,get_inflections);
+        }
 		var wn=wrap_class("span","inflect",text(w))
-		if(wc.e2) wn.onclick=get_inflections
+		if(wc.e2) wn.onclick=get_gloss
 		return wn
 	    }
 	    function word(w) {
@@ -239,37 +241,7 @@ wc.translate=function(redo) {
 	    gftranslate.translate(text,f.from.value,wc.languages || f.to.value,i,count,step3)
 	}
 	function step2(text) { trans(text,0,10) }
-	function step2cnl(text,ix) {
+	step2(so.input)
-	    function step3cnl(results) {
-		var trans=results[0].translations
-		if(trans && trans.length>=1) {
-		    for(var i=0;i<trans.length;i++) {
-			var r=trans[i]
-			r.prob=0
-			showit(r,cnl)
-		    }
-		}
-		step2cnl(text,ix+1)
-	    }
-	    if(ix<wc.selected_cnls.length) {
-		var g=wc.cnls[wc.selected_cnls[ix]]
-		var gi=g.grammar_info
-		var langs=gi.languages.map(function(l) { return l.name; })
-		var cnl=gi.name
-		var from=cnl+f.from.value,to=cnl+f.to.value
-		if(elem(from,langs) && elem(to,langs))
-		    g.pgf_online.translate({from:from,
-					    //to:to,
-					    lexer:"text",unlexer:"text",
-					    jsontree:true,input:text},
-					   step3cnl,
-					   function(){step2cnl(text,ix+1)})
-		else step2cnl(text,ix+1)
-	    }
-	    else step2(text)
-	}
-	if(wc.selected_cnls) step2cnl(so.input,0)
-	else step2(so.input)
     }
 
     function change_segment_to(so,to) {
@@ -404,8 +376,13 @@ wc.init_languages=function () {
 	function update_menu(m) {
 	    var l=m.value
 	    clear(m)
-	    for(var i=0;i<langs.length;i++)
+	    for(var i=0;i<langs.length;i++) {
-		m.appendChild(option(concname(langs[i]),langs[i]))
+            const code = langs[i]
+            const name = langname[code]
+            if (name) {
+                m.appendChild(option(concname(langs[i]),langs[i]))
+            }
+        }
 	    if(langset[l]) m.value=l
 	}
 	update_menu(wc.f.from)
@@ -428,86 +405,6 @@ wc.init_speech=function() {
     }
 }
 
-
-wc.show_grammarbox=function() {
-    wc.grammarbox.parentNode.style.display="block";
-}
-
-wc.hide_grammarbox=function() {
-    wc.grammarbox.parentNode.style.display="";
-    clear(wc.grammarbox)
-}
-
-wc.init_cnl=function(grammar) {
-    var g
-    if(wc.cnls[grammar]) g=wc.cnls[grammar]
-    else g=wc.cnls[grammar]={}
-    g.pgf_online=pgf_online({})
-    g.pgf_online.switch_grammar(grammar)
-    g.pgf_online.grammar_info(function(info){g.grammar_info=info})
-}
-
-wc.init_cnls=function() {
-    var gs=wc.selected_cnls
-    for(var i=0;i<gs.length;i++) wc.init_cnl(gs[i])
-}
-
-wc.select_grammars=function() {
-    function done() {
-	wc.hide_grammarbox()
-	var gs=[]
-	var glist=list.children
-	for(var i=0;i<glist.length;i++)
-	    if(glist[i].cb.checked) gs.push(glist[i].grammar)
-	wc.selected_cnls=gs
-	wc.init_cnls()
-	wc.local.put("cnls",wc.selected_cnls)
-	wc.translate(true)
-    }
-    function cancel() {
-	wc.hide_grammarbox()
-    }
-    function remove(x,xs) {
-	function other(y) { return y!=x; }
-	return filter(other,xs)
-    }
-    function checkbox(grammar,checked) {
-	var vb=node("input",{type:"checkbox"})
-	vb.checked=checked
-	return vb
-    }
-    function grammar_pick(grammar,checked) {
-	var cb=checkbox(grammar,checked)
-	var p=[cb,text(" "+grammar.split(".pgf")[0])]
-	var dt=node("dt",{class:"grammar_pick"},p)
-	dt.cb=cb
-	dt.grammar=grammar
-	return dt
-    }
-    function show_list(grammars) {
-	var sg=wc.selected_cnls
-	for(var i=0;i<sg.length;i++) {
-	    if(elem(sg[i],grammars))
-		list.appendChild(grammar_pick(sg[i],true))
-	    else
-		remove(sg[i],wc.selected_cnls)
-	}
-	for(var i=0;i<grammars.length;i++)
-	    if(!elem(grammars[i],wc.selected_cnls))
-		list.appendChild(grammar_pick(grammars[i],false))
-    }
-    
-    clear(wc.grammarbox)
-    wc.grammarbox.appendChild(wrap("h2",[button("X",cancel),text("Select which domain-specific grammars to use")]))
-    wc.grammarbox.appendChild(text("These grammars are tried before the wide-coverage grammar. They can give higher quality translations within their respective domains."))
-    var list=empty("dl")
-    wc.grammarbox.appendChild(list)
-    wc.grammarbox.appendChild(button("OK",done))
-    wc.grammarbox.appendChild(button("Cancel",cancel))
-    wc.show_grammarbox()
-    wc.pgf_online.get_grammarlist(show_list)
-}
-
 wc.initialize=function(grammar_name,grammar_url) {
     if(grammar_name && grammar_url) {
 	gftranslate.grammar=grammar_name
@@ -519,7 +416,6 @@ wc.initialize=function(grammar_name,grammar_url) {
     wc.pgf_online=pgf_online({});
     wc.local=appLocalStorage("gf.wc."+gftranslate.grammar+".")
     wc.load()
-    wc.init_cnls()
     initialize_sorting(["DT"],["grammar_pick"])
     wc.f.input.focus()
 }

src/compiler/www/wc.html

@@ -92,7 +92,6 @@ h2 > input { float: right; }
   </select>
   <input name=colors type=checkbox checked onchange="wc.colors()"> Colors
   <td><button name=translate type=submit><strong>Translate</strong></button>
-      <input type=button name=grammars onclick="wc.select_grammars()" value="Grammars...">
   <tr><td class=input colspan=2>
     <div class=input>
   <textarea name=input rows=5 style="width: 100%" onkeyup="wc.delayed_translate()"></textarea>

src/runtime/c/configure.ac

@@ -2,6 +2,7 @@ AC_INIT(Portable Grammar Format library, 3.0-pre,
 		 http://www.grammaticalframework.org/, 
 		 libpgf)
 AC_PREREQ(2.58)
+LT_INIT([])
 
 AC_CONFIG_AUX_DIR([scripts])
 AC_CONFIG_MACRO_DIR([m4])

src/runtime/c/pgf/compute.cxx

@@ -0,0 +1,142 @@
+#include "data.h"
+#include "compute.h"
+
+PgfExpr PgfEvalExpr::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body)
+{
+    if (stack != NULL) {
+        ExprNode *tmp;
+        tmp = stack->next;
+        stack->next = env;
+        env = stack;
+        stack = tmp;
+        return m->match_expr(this, body);
+    } else {
+        return 0;
+    }
+}
+
+PgfExpr PgfEvalExpr::eapp(PgfExpr fun, PgfExpr arg)
+{
+    ExprNode node;
+    node.e = arg;
+    node.value = 0;
+    node.next = stack;
+    stack = &node;
+    PgfExpr e = m->match_expr(this, fun);
+    if (node.value != 0) {
+        //u->free_ref(node.value);
+    }
+    return e;
+}
+
+PgfExpr PgfEvalExpr::elit(PgfLiteral lit)
+{
+    lit = m->match_lit(this, lit);
+    PgfExpr e = u->elit(lit);
+    u->free_ref(lit);
+    return e;
+}
+
+PgfExpr PgfEvalExpr::emeta(PgfMetaId meta_id)
+{
+    return apply(u->emeta(meta_id));
+}
+
+PgfExpr PgfEvalExpr::efun(PgfText *name)
+{
+    return apply(u->efun(name));
+}
+
+PgfExpr PgfEvalExpr::evar(int index)
+{
+    ExprNode *node = env;
+    while (index > 0) {
+        if (node == NULL) {
+            err->type = PGF_EXN_PGF_ERROR;
+            err->msg  = strdup("Unbounded variable");
+            return 0;
+        }
+        node = node->next;
+    }
+
+    if (node == NULL) {
+        err->type = PGF_EXN_PGF_ERROR;
+        err->msg  = strdup("Unbounded variable");
+        return 0;
+    }
+    return apply(force(node));
+}
+
+PgfExpr PgfEvalExpr::etyped(PgfExpr expr, PgfType ty)
+{
+    return m->match_expr(this, expr);
+}
+
+PgfExpr PgfEvalExpr::eimplarg(PgfExpr expr)
+{
+    return m->match_expr(this, expr);
+}
+
+PgfLiteral PgfEvalExpr::lint(size_t size, uintmax_t *val)
+{
+    return u->lint(size, val);
+}
+
+PgfLiteral PgfEvalExpr::lflt(double val)
+{
+    return u->lflt(val);
+}
+
+PgfLiteral PgfEvalExpr::lstr(PgfText *val)
+{
+    return u->lstr(val);
+}
+
+PgfType PgfEvalExpr::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+                          PgfText *name,
+                          size_t n_exprs, PgfExpr *exprs)
+{
+    return 0;
+}
+
+void PgfEvalExpr::free_ref(object x)
+{
+    return u->free_ref(x);
+}
+
+PgfExpr PgfEvalExpr::force(ExprNode *node)
+{
+    if (node->value == 0) {
+        PgfEvalExpr eval(pgf,m,u,env,err);
+        node->value = m->match_expr(&eval, node->e);
+    }
+    return node->value;
+}
+
+PgfExpr PgfEvalExpr::apply(PgfExpr e)
+{
+    while (stack != NULL) {
+        PgfExpr arg = force(stack);
+        if (arg == 0) {
+            u->free_ref(e);
+            return 0;
+        }
+
+        PgfExpr app = u->eapp(e,arg);
+        u->free_ref(e);
+        e = app;
+        stack = stack->next;
+    }
+    return e;
+}
+
+PgfEvalExpr::PgfEvalExpr(ref<PgfPGF> pgf,
+                         PgfMarshaller *m, PgfUnmarshaller *u,
+                         ExprNode *env,
+                         PgfExn *err)
+{
+    this->m = m;
+    this->u = u;
+    this->stack = NULL;
+    this->env   = env;
+}

src/runtime/c/pgf/compute.h

@@ -0,0 +1,69 @@
+#ifndef COMPUTE_H
+#define COMPUTE_H
+
+class PGF_INTERNAL_DECL PgfEvalExpr : public PgfUnmarshaller
+{
+    ref<PgfPGF> pgf;
+    PgfMarshaller *m;
+    PgfUnmarshaller *u;
+    PgfExn *err;
+
+    struct Value {
+        Value *next;                // chain for garabage collection
+    };
+
+    struct VThunk : Value {
+        PgfExpr e;
+    };
+
+    struct VApp : Value {
+        ref<PgfConcrLin> lin;
+        Value *args[];
+    };
+
+    struct VMeta : Value {
+        PgfMetaId id;
+        Value *args[];
+    };
+
+    struct VClosure : Value {
+        PgfExpr e;
+    };
+
+    struct ExprNode {
+        PgfExpr e;
+        PgfExpr value;
+        ExprNode *next;
+    };
+
+    ExprNode *stack;
+    ExprNode *env;
+
+    virtual PgfExpr eabs(PgfBindType bind_type, PgfText *name, PgfExpr body);
+    virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);
+    virtual PgfExpr elit(PgfLiteral lit);
+    virtual PgfExpr emeta(PgfMetaId meta_id);
+    virtual PgfExpr efun(PgfText *name);
+    virtual PgfExpr evar(int index);
+    virtual PgfExpr etyped(PgfExpr expr, PgfType ty);
+    virtual PgfExpr eimplarg(PgfExpr expr);
+    virtual PgfLiteral lint(size_t size, uintmax_t *val);
+    virtual PgfLiteral lflt(double val);
+    virtual PgfLiteral lstr(PgfText *val);
+
+    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+                         PgfText *name,
+                         size_t n_exprs, PgfExpr *exprs);
+    virtual void free_ref(object x);
+
+    PgfExpr force(ExprNode *node);
+    PgfExpr apply(PgfExpr e);
+
+public:
+    PgfEvalExpr(ref<PgfPGF> pgf,
+                PgfMarshaller *m, PgfUnmarshaller *u,
+                ExprNode *env,
+                PgfExn *err);
+};
+
+#endif // COMPUTE_H

src/runtime/c/pgf/data.cxx

@@ -40,8 +40,12 @@ void PgfConcr::release(ref<PgfConcr> concr)
     namespace_release(concr->cflags);
     namespace_release(concr->lins);
     namespace_release(concr->lincats);
-    phrasetable_release(concr->phrasetable);
     namespace_release(concr->printnames);
+    phrasetable_release(concr->phrasetable1);
+    phrasetable_release(concr->phrasetable2);
+    phrasetable_release(concr->phrasetable3);
+    phrasetable_release(concr->phrasetable4);
+    epsilontable_release(concr->epsilontable);
     PgfDB::free(concr, concr->name.size+1);
 }
 
@@ -52,17 +56,10 @@ void PgfConcrLincat::release(ref<PgfConcrLincat> lincat)
     }
     vector<ref<PgfText>>::release(lincat->fields);
 
-	for (size_t i = 0; i < lincat->args.size(); i++) {
+    for (ref<PgfConcrRule> rule : lincat->rules) {
-        PgfLParam::release(lincat->args[i].param);
+        PgfConcrRule::release(rule);
     }
-    vector<PgfPArg>::release(lincat->args);
+    vector<ref<PgfConcrRule>>::release(lincat->rules);
-
-    for (ref<PgfPResult> res : lincat->res) {
-        PgfPResult::release(res);
-    }
-    vector<ref<PgfPResult>>::release(lincat->res);
-
-    vector<ref<PgfSequence>>::release(lincat->seqs);
 
     PgfDB::free(lincat, lincat->name.size+1);
 }
@@ -72,27 +69,15 @@ void PgfLParam::release(ref<PgfLParam> param)
     PgfDB::free(param, param->n_terms*sizeof(param->terms[0]));
 }
 
-void PgfPResult::release(ref<PgfPResult> res)
+static void symbols_release(vector<PgfSymbol> syms)
 {
-    if (res->vars != 0)
+	for (PgfSymbol sym : syms) {
-        vector<PgfVariableRange>::release(res->vars);
-    PgfDB::free(res, res->param.n_terms*sizeof(res->param.terms[0]));
-}
-
-void PgfSequence::release(ref<PgfSequence> seq)
-{
-	for (PgfSymbol sym : seq->syms) {
         switch (ref<PgfSymbol>::get_tag(sym)) {
         case PgfSymbolCat::tag: {
             auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
             PgfDB::free(sym_cat, sym_cat->r.n_terms*sizeof(sym_cat->r.terms[0]));
             break;
         }
-        case PgfSymbolLit::tag: {
-            auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
-            PgfDB::free(sym_lit, sym_lit->r.n_terms*sizeof(sym_lit->r.terms[0]));
-            break;
-        }
         case PgfSymbolVar::tag:
             PgfDB::free(ref<PgfSymbolVar>::untagged(sym));
             break;
@@ -103,9 +88,11 @@ void PgfSequence::release(ref<PgfSequence> seq)
         }
         case PgfSymbolKP::tag: {
             auto sym_kp = ref<PgfSymbolKP>::untagged(sym);
-            PgfSequence::release(sym_kp->default_form);
+            symbols_release(sym_kp->default_form);
+            vector<PgfSymbol>::release(sym_kp->default_form);
             for (size_t i = 0; i < sym_kp->alts.size(); i++) {
-                PgfSequence::release(sym_kp->alts[i].form);
+                symbols_release(sym_kp->alts[i].form);
+                vector<PgfSymbol>::release(sym_kp->alts[i].form);
                 for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) {
                     text_db_release(sym_kp->alts[i].prefixes[j]);
                 }
@@ -124,22 +111,31 @@ void PgfSequence::release(ref<PgfSequence> seq)
             throw pgf_error("Unknown symbol tag");
         }
     }
-    inline_vector<PgfSymbol>::release(&PgfSequence::syms, seq);
+}
+
+void PgfConcrRule::release(ref<PgfConcrRule> rule)
+{
+    vector<size_t>::release(rule->ranges);
+
+    PgfLParam::release(rule->res);
+
+    for (ref<PgfLParam> arg : rule->args) {
+        PgfLParam::release(arg);
+    }
+    vector<ref<PgfLParam>>::release(rule->args);
+
+    PgfLParam::release(rule->lin_idx);
+
+    symbols_release(rule->syms.as_vector());
+    inline_vector<PgfSymbol>::release(&PgfConcrRule::syms, rule);
 }
 
 void PgfConcrLin::release(ref<PgfConcrLin> lin)
 {
-    for (size_t i = 0; i < lin->args.size(); i++) {
+    for (ref<PgfConcrRule> rule : lin->rules) {
-        PgfLParam::release(lin->args[i].param);
+        PgfConcrRule::release(rule);
     }
-    vector<PgfPArg>::release(lin->args);
+    vector<ref<PgfConcrRule>>::release(lin->rules);
-
-    for (ref<PgfPResult> res : lin->res) {
-        PgfPResult::release(res);
-    }
-    vector<ref<PgfPResult>>::release(lin->res);
-
-    vector<ref<PgfSequence>>::release(lin->seqs);
 
     PgfDB::free(lin, lin->name.size+1);
 }

src/runtime/c/pgf/data.h

@@ -87,9 +87,9 @@ struct PgfConcr;
 #include "text.h"
 #include "vector.h"
 #include "namespace.h"
-#include "phrasetable.h"
 #include "probspace.h"
 #include "expr.h"
+#include "intervalmap.h"
 
 struct PGF_INTERNAL_DECL PgfFlag {
     PgfLiteral value;
@@ -146,21 +146,8 @@ struct PGF_INTERNAL_DECL PgfPArg {
     ref<PgfLParam> param;
 };
 
-struct PGF_INTERNAL_DECL PgfPResult {
-    vector<PgfVariableRange> vars; 
-    PgfLParam param;
-
-    static void release(ref<PgfPResult> res);
-};
-
 typedef object PgfSymbol;
 
-struct PGF_INTERNAL_DECL PgfSequence {
-	inline_vector<PgfSymbol> syms;
-
-    static void release(ref<PgfSequence> seq);
-};
-
 struct PGF_INTERNAL_DECL PgfSequenceBackref {
     object container;
     size_t seq_index;
@@ -172,12 +159,6 @@ struct PGF_INTERNAL_DECL PgfSymbolCat {
     PgfLParam r;
 };
 
-struct PGF_INTERNAL_DECL PgfSymbolLit {
-    static const uint8_t tag = 1;
-    size_t d;
-    PgfLParam r;
-};
-
 struct PGF_INTERNAL_DECL PgfSymbolVar {
     static const uint8_t tag = 2;
     size_t d, r;
@@ -189,7 +170,7 @@ struct PGF_INTERNAL_DECL PgfSymbolKS {
 };
 
 struct PGF_INTERNAL_DECL PgfAlternative {
-	ref<PgfSequence> form;
+	vector<PgfSymbol> form;
 	/**< The form of this variant as a list of tokens. */
 
 	vector<ref<PgfText>> prefixes;
@@ -199,7 +180,7 @@ struct PGF_INTERNAL_DECL PgfAlternative {
 
 struct PGF_INTERNAL_DECL PgfSymbolKP {
     static const uint8_t tag = 4;
-    ref<PgfSequence> default_form;
+    vector<PgfSymbol> default_form;
     inline_vector<PgfAlternative> alts;
 };
 
@@ -227,15 +208,24 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT {
     static const uint8_t tag = 10;
 };
 
+struct PGF_INTERNAL_DECL PgfConcrRule {
+    vector<size_t> ranges;
+    ref<PgfLParam> res;
+    object container;
+    vector<ref<PgfLParam>> args;
+    ref<PgfLParam> lin_idx;
+    inline_vector<PgfSymbol> syms;
+
+    static void release(ref<PgfConcrRule> seq);
+};
+
 struct PGF_INTERNAL_DECL PgfConcrLincat {
     static const uint8_t tag = 0;
 
     ref<PgfAbsCat> abscat;
 
     size_t n_lindefs;
-    vector<PgfPArg> args;
+    vector<ref<PgfConcrRule>> rules;
-    vector<ref<PgfPResult>> res;
-    vector<ref<PgfSequence>> seqs;
     vector<ref<PgfText>> fields;
 
     PgfText name;
@@ -249,9 +239,7 @@ struct PGF_INTERNAL_DECL PgfConcrLin {
     ref<PgfAbsFun> absfun;
     ref<PgfConcrLincat> lincat;
 
-    vector<PgfPArg> args;
+    vector<ref<PgfConcrRule>> rules;
-    vector<ref<PgfPResult>> res;
-    vector<ref<PgfSequence>> seqs;
 
     PgfText name;
 
@@ -267,143 +255,19 @@ struct PGF_INTERNAL_DECL PgfConcrPrintname {
 
 #define containerof(T,field,p) (T*) (((char*) p)-offsetof(T,field))
 
-struct PGF_INTERNAL_DECL PgfLCEdge {
+#include "phrasetable.h"
-    struct {
-        ref<PgfConcrLincat> lincat;
-        struct {
-            size_t i0;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.value,this);
-                return edge->terms[i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.value,this);
-                return edge->from.lin_idx.n_offset;
-            }
-        } value;
-        struct {
-            size_t i0;
-            size_t n_offset;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.lin_idx,this);
-                return edge->terms[n_offset+i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,from.lin_idx,this);
-                return edge->to.value.n_offset-n_offset;
-            }
-        } lin_idx;
-    } from;
-
-    struct {
-        ref<PgfConcrLincat> lincat;
-        struct {
-            size_t i0;
-            size_t n_offset;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.value,this);
-                return edge->terms[n_offset+i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.value,this);
-                return edge->to.lin_idx.n_offset-n_offset;
-            }
-        } value;
-        struct {
-            size_t i0;
-            size_t n_offset;
-            term& operator[](int i) {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.lin_idx,this);
-                return edge->terms[n_offset+i];
-            }
-            size_t size() {
-                PgfLCEdge *edge = containerof(PgfLCEdge,to.lin_idx,this);
-                return edge->n_terms-n_offset;
-            }
-        } lin_idx;
-    } to;
-
-    struct {
-        size_t n_vars;
-        PgfVariableRange& operator[](int i) {
-            PgfLCEdge *edge = containerof(PgfLCEdge,vars,this);
-            return ((PgfVariableRange*)(((term*) (edge+1))+edge->n_terms))[i];
-        }
-        size_t size() {
-            return n_vars;
-        }
-    } vars;
-
-    size_t n_terms;
-    term terms[];
-
-    static ref<PgfLCEdge> alloc(size_t n_terms1, size_t n_terms2, size_t n_terms3, size_t n_terms4, size_t n_vars) {
-        auto edge = PgfDB::malloc<PgfLCEdge>((n_terms1+n_terms2+n_terms3+n_terms4)*sizeof(term)+n_vars*sizeof(PgfVariableRange));
-        edge->from.lin_idx.n_offset = n_terms1;
-        edge->to.value.n_offset = n_terms1+n_terms2;
-        edge->to.lin_idx.n_offset = n_terms1+n_terms2+n_terms3;
-        edge->n_terms = n_terms1+n_terms2+n_terms3+n_terms4;
-        edge->vars.n_vars = n_vars;
-        return edge;
-    }
-};
-
-struct PGF_INTERNAL_DECL PgfLRShift {
-    size_t next_state;
-    ref<PgfConcrLincat> lincat;
-    size_t r;
-};
-
-struct PGF_INTERNAL_DECL PgfLRShiftKS {
-    size_t next_state;
-    ref<PgfSequence> seq;
-    size_t sym_idx;
-};
-
-struct PgfLRReduceArg;
-
-struct PGF_INTERNAL_DECL PgfLRProduction {
-    ref<PgfConcrLin> lin;
-    size_t index;
-    vector<ref<PgfLRReduceArg>> args;
-};
-
-struct PGF_INTERNAL_DECL PgfLRReduceArg {
-    static const uint8_t tag = 2;
-
-    size_t id;
-    size_t n_prods;
-    PgfLRProduction prods[];
-};
-
-struct PGF_INTERNAL_DECL PgfLRReduce {
-    object lin_obj;
-    size_t seq_idx;
-    size_t depth;
-
-    struct Arg {
-        ref<PgfLRReduceArg> arg;
-        size_t stk_idx;
-    };
-
-    vector<Arg> args;
-};
-
-struct PGF_INTERNAL_DECL PgfLRState {
-    vector<PgfLRShift> shifts;
-    vector<PgfLRShiftKS> tokens;
-    size_t next_bind_state;
-    vector<PgfLRReduce> reductions;
-};
 
 struct PGF_INTERNAL_DECL PgfConcr {
     Namespace<PgfFlag> cflags;
     Namespace<PgfConcrLin> lins;
     Namespace<PgfConcrLincat> lincats;
-    PgfPhrasetable phrasetable;
+    PgfPhrasetable<PgfSymbolKS>    phrasetable1;  // suspended on token
+    PgfPhrasetable<PgfConcrLincat> phrasetable2;  // suspended on lincat
+    PgfPhrasetable<PgfCCat>        phrasetable3;  // suspended on ccat
+    PgfPhrasetable<PgfSymbolBIND>  phrasetable4;  // suspended on bind
+    PgfEpsilontable epsilontable;
     Namespace<PgfConcrPrintname> printnames;
-
+    PgfMetaId last_fid;
-    vector<PgfLRState> lrtable;
 
     PgfText name;
 

src/runtime/c/pgf/db.cxx

@@ -1839,32 +1839,44 @@ void PgfDB::resize_map(size_t new_size, bool writeable)
 // OSX does not implement mremap or MREMAP_MAYMOVE
 #ifndef MREMAP_MAYMOVE
 	if (fd >= 0) {
-		if (munmap(base, mmap_size) == -1)
+		if (munmap(base, mmap_size) == -1) {
+            pthread_rwlock_unlock(&ms->rwlock);
 			throw pgf_systemerror(errno);
+        }
 		base = NULL;
 		if (ms->file_size != new_size) {
-			if (ftruncate(fd, page_size+new_size) < 0)
+			if (ftruncate(fd, page_size+new_size) < 0) {
+                pthread_rwlock_unlock(&ms->rwlock);
 				throw pgf_systemerror(errno, filepath);
+            }
 		}
         int prot = writeable ? PROT_READ | PROT_WRITE : PROT_READ;
         new_base =
             (unsigned char *) mmap(0, new_size, prot, MAP_SHARED, fd, page_size);
-		if (new_base == MAP_FAILED)
+		if (new_base == MAP_FAILED) {
+            pthread_rwlock_unlock(&ms->rwlock);
 			throw pgf_systemerror(errno);
+        }
 	} else {
 		new_base = (unsigned char *) ::realloc(base, new_size);
-		if (new_base == NULL)
+		if (new_base == NULL) {
+            pthread_rwlock_unlock(&ms->rwlock);
 			throw pgf_systemerror(ENOMEM);
+        }
 	}
 #else
 	if (fd >= 0 && ms->file_size != new_size) {
-		if (ftruncate(fd, page_size+new_size) < 0)
+		if (ftruncate(fd, page_size+new_size) < 0) {
+            pthread_rwlock_unlock(&ms->rwlock);
 			throw pgf_systemerror(errno, filepath);
+        }
 	}
 	new_base =
 		(unsigned char *) mremap(base, mmap_size, new_size, MREMAP_MAYMOVE);
-	if (new_base == MAP_FAILED)
+	if (new_base == MAP_FAILED) {
+        pthread_rwlock_unlock(&ms->rwlock);
 		throw pgf_systemerror(errno);
+    }
 #endif
 
     base = new_base;

src/runtime/c/pgf/expr.cxx

@@ -111,26 +111,30 @@ PgfType PgfDBMarshaller::match_type(PgfUnmarshaller *u, PgfType ty)
 
 PgfExpr PgfDBUnmarshaller::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body)
 {
+    body = m->match_expr(this, body);
     ref<PgfExprAbs> eabs =
         PgfDB::malloc<PgfExprAbs>(name->size+1);
     eabs->bind_type = bind_type;
-    eabs->body = m->match_expr(this, body);
+    eabs->body = body;
     memcpy(&eabs->name, name, sizeof(PgfText)+name->size+1);
     return eabs.tagged();
 }
 
 PgfExpr PgfDBUnmarshaller::eapp(PgfExpr fun, PgfExpr arg)
 {
+    fun = m->match_expr(this, fun);
+    arg = m->match_expr(this, arg);
     ref<PgfExprApp> eapp = PgfDB::malloc<PgfExprApp>();
-    eapp->fun = m->match_expr(this, fun);
+    eapp->fun = fun;
-	eapp->arg = m->match_expr(this, arg);
+	eapp->arg = arg;
     return eapp.tagged();
 }
 
 PgfExpr PgfDBUnmarshaller::elit(PgfLiteral lit)
 {
+    lit = m->match_lit(this, lit);
     ref<PgfExprLit> elit = PgfDB::malloc<PgfExprLit>();
-    elit->lit = m->match_lit(this, lit);
+    elit->lit = lit;
     return elit.tagged();
 }
 
@@ -158,16 +162,19 @@ PgfExpr PgfDBUnmarshaller::evar(int index)
 
 PgfExpr PgfDBUnmarshaller::etyped(PgfExpr expr, PgfType ty)
 {
+    expr = m->match_expr(this, expr);
+    ty   = m->match_type(this, ty);
     ref<PgfExprTyped> etyped = PgfDB::malloc<PgfExprTyped>();
-    etyped->expr = m->match_expr(this, expr);
+    etyped->expr = expr;
-    etyped->type = m->match_type(this, ty);
+    etyped->type = ty;
     return etyped.tagged();
 }
 
 PgfExpr PgfDBUnmarshaller::eimplarg(PgfExpr expr)
 {
+    expr = m->match_expr(this, expr);
     ref<PgfExprImplArg> eimpl = current_db->malloc<PgfExprImplArg>();
-	eimpl->expr = m->match_expr(this, expr);
+	eimpl->expr = expr;
     return eimpl.tagged();
 }
 
@@ -298,17 +305,16 @@ PgfType PgfInternalMarshaller::match_type(PgfUnmarshaller *u, PgfType ty)
                     tp->exprs.size(), tp->exprs.get_data());
 }
 
-PgfExprParser::PgfExprParser(PgfText *input, PgfUnmarshaller *unmarshaller)
+PgfExprParser::PgfExprParser(PgfText *input, size_t byte_pos, PgfUnmarshaller *unmarshaller)
 {
     inp = input;
-    pos = (const char*) &inp->text;
-	ch  = ' ';
     u   = unmarshaller;
     token_pos = NULL;
     token_value = NULL;
     bs = NULL;
 
-	token();
+    reset_pos(byte_pos);
+    token();
 }
 
 PgfExprParser::~PgfExprParser()
@@ -347,11 +353,6 @@ void PgfExprParser::putc(uint32_t ucs)
     *(p++) = 0;
 }
 
-bool PgfExprParser::eof()
-{
-    return (token_tag == PGF_TOKEN_EOF);
-}
-
 PGF_INTERNAL bool
 pgf_is_ident_first(uint32_t ucs)
 {
@@ -431,6 +432,30 @@ bool PgfExprParser::str_char()
     return getc();
 }
 
+void PgfExprParser::raw_token()
+{
+	token_tag   = PGF_TOKEN_STR;
+    token_pos   = pos;
+	token_value = NULL;
+
+	while (pgf_utf8_is_space(ch)) {
+        token_pos   = pos;
+        if (!getc()) {
+            token_tag = PGF_TOKEN_EOF;
+            return;
+        }
+	}
+
+	while (!pgf_utf8_is_space(ch)) {
+        putc(ch);
+        if (!getc())
+            break;
+	}
+
+    if (token_value == NULL)
+        token_tag   = PGF_TOKEN_EOF;
+}
+
 void PgfExprParser::token()
 {
     if (token_value != NULL)

src/runtime/c/pgf/expr.h

@@ -170,11 +170,12 @@ class PGF_INTERNAL_DECL PgfExprParser {
     void putc(uint32_t ch);
 
 public:
-    PgfExprParser(PgfText* input, PgfUnmarshaller *unmarshaller);
+    PgfExprParser(PgfText* input, size_t byte_pos, PgfUnmarshaller *unmarshaller);
     ~PgfExprParser();
 
     bool str_char();
     void token();
+    void raw_token();
     bool lookahead(int ch);
 
     bool parse_bind();
@@ -189,8 +190,15 @@ public:
     PgfType parse_type();
     PgfTypeHypo *parse_context(size_t *p_n_hypos);
 
-    bool eof();
+    bool is_eof()   { return (token_tag == PGF_TOKEN_EOF); }
+    bool is_int()   { return (token_tag == PGF_TOKEN_INT); }
+    bool is_flt()   { return (token_tag == PGF_TOKEN_FLT); }
+    bool is_str()   { return (token_tag == PGF_TOKEN_STR); }
+    bool is_ident() { return (token_tag == PGF_TOKEN_IDENT); }
 
+    void reset_pos(size_t pos) { this->pos = &inp->text[pos]; this->ch = ' '; }
+
+    const PgfText *get_token_value() { return token_value; }
     const char *get_token_pos() { return token_pos; }
 };
 

src/runtime/c/pgf/intervalmap.h

@@ -0,0 +1,467 @@
+#ifndef INTERVAL_MAP_H
+#define INTERVAL_MAP_H
+
+typedef std::pair<size_t,size_t> interval_t;
+
+template<class V>
+class PGF_INTERNAL_DECL interval_map {
+    const static size_t DELTA = 3;
+    const static size_t RATIO = 2;
+
+    struct Node {
+        size_t sz;
+        size_t start, end, max;
+
+        Node *left;
+        Node *right;
+
+        V value;
+
+        Node(size_t start, size_t end)
+        {
+            this->sz = 1;
+            this->start = start;
+            this->end = end;
+            this->max = end;
+            this->left = NULL;
+            this->right = NULL;
+            memset(&value, 0, sizeof(value));
+        }
+    };
+
+    Node *root;
+
+    static
+    Node *insert(Node *node, size_t start, size_t end, Node **target)
+    {
+        if (node == NULL) {
+            node = new Node(start, end);
+            *target = node;
+            return node;
+        }
+
+        int cmp;
+        if (start < node->start)
+            cmp = -1;
+        else if (start > node->start)
+            cmp = 1;
+        else if (end < node->end)
+            cmp = -1;
+        else if (end > node->end)
+            cmp = 1;
+        else
+            cmp = 0;
+
+        if (cmp < 0) {
+            Node *left = insert(node->left, start, end, target);
+            node = upd_node(node,left,node->right);
+            return balanceL(node);
+        } else if (cmp > 0) {
+            Node *right = insert(node->right, start, end, target);
+            node = upd_node(node,node->left,right);
+            return balanceR(node);
+        } else {
+            *target = node;
+            return node;
+        }
+    }
+
+    static size_t size(Node *node)
+    {
+        if (node == 0)
+            return 0;
+        return node->sz;
+    }
+
+    static
+    Node *upd_node(Node *node, Node *left, Node *right)
+    {
+        node->sz        = 1+size(left)+size(right);
+        node->max       = std::max<size_t>((left  == NULL) ? node->end : left->max,
+                                           (right == NULL) ? node->end : right->max);
+        node->left      = left;
+        node->right     = right;
+        return node;
+    }
+
+    static
+    Node *balanceL(Node *node)
+    {
+        if (node->right == NULL) {
+            if (node->left == NULL) {
+                return node;
+            } else {
+                if (node->left->left == NULL) {
+                    if (node->left->right == NULL) {
+                        return node;
+                    } else {
+                        Node *left_right = node->left->right;
+                        Node *left  = upd_node(node->left,NULL,NULL);
+                        Node *right = upd_node(node,NULL,NULL);
+                        return upd_node(left_right,
+                                        left,
+                                        right);
+                    }
+                } else {
+                    if (node->left->right == 0) {
+                        Node *left  = node->left;
+                        Node *right = upd_node(node,NULL,NULL);
+                        return upd_node(left,
+                                        left->left,
+                                        right);
+                    } else {
+                        if (node->left->right->sz < RATIO * node->left->left->sz) {
+                            Node *left  = node->left;
+                            Node *right =
+                                upd_node(node,
+                                         left->right,
+                                         NULL);
+                            return upd_node(left,
+                                            left->left,
+                                            right);
+                        } else {
+                            Node *left_right = node->left->right;
+                            Node *left =
+                                upd_node(node->left,
+                                         node->left->left,
+                                         left_right->left);
+                            Node *right =
+                                upd_node(node,
+                                         left_right->right,
+                                         NULL);
+                            return upd_node(left_right,
+                                            left,
+                                            right);
+                        }
+                    }
+                }
+            }
+        } else {
+            if (node->left == NULL) {
+                return node;
+            } else {
+                if (node->left->sz > DELTA*node->right->sz) {
+                    if (node->left->right->sz < RATIO*node->left->left->sz) {
+                        Node *left  = node->left;
+                        Node *right =
+                            upd_node(node,
+                                     left->right,
+                                     node->right);
+                        return upd_node(left,
+                                        left->left,
+                                        right);
+                    } else {
+                        Node *left_right = node->left->right;
+                        Node *left  =
+                            upd_node(node->left,
+                                     node->left->left,
+                                     left_right->left);
+                        Node *right =
+                            upd_node(node,
+                                     left_right->right,
+                                     node->right);
+                        return upd_node(left_right,
+                                        left,
+                                        right);
+                    }
+                } else {
+                    return node;
+                }
+            }
+        }
+    }
+
+    static
+    Node *balanceR(Node *node)
+    {
+        if (node->left == NULL) {
+            if (node->right == NULL) {
+                return node;
+            } else {
+                if (node->right->left == NULL) {
+                    if (node->right->right == NULL) {
+                        return node;
+                    } else {
+                        Node *right = node->right;
+                        Node *left  =
+                            upd_node(node,
+                                     NULL,
+                                     NULL);
+                        return upd_node(right,
+                                        left,
+                                        right->right);
+                    }
+                } else {
+                    if (node->right->right == NULL) {
+                        Node *right_left = node->right->left;
+                        Node *right =
+                            upd_node(node->right,NULL,NULL);
+                        Node *left =
+                            upd_node(node,NULL,NULL);
+                        return upd_node(right_left,
+                                        left,
+                                        right);
+                    } else {
+                        if (node->right->left->sz < RATIO * node->right->right->sz) {
+                            Node *right = node->right;
+                            Node *left  =
+                                upd_node(node,
+                                         NULL,
+                                         right->left);
+                            return upd_node(right,
+                                            left,
+                                            right->right);
+                        } else {
+                            Node *right_left = node->right->left;
+                            Node *right =
+                                upd_node(node->right,
+                                         right_left->right,
+                                         node->right->right);
+                            Node *left =
+                                upd_node(node,
+                                         NULL,
+                                         right_left->left);
+                            return upd_node(right_left,
+                                            left,
+                                            right);
+                        }
+                    }
+                }
+            }
+        } else {
+            if (node->right == NULL) {
+                return node;
+            } else {
+                if (node->right->sz > DELTA*node->left->sz) {
+                    if (node->right->left->sz < RATIO*node->right->right->sz) {
+                        Node *right = node->right;
+                        Node *left =
+                            upd_node(node,
+                                     node->left,
+                                     right->left);
+                        return upd_node(right,
+                                        left,
+                                        right->right);
+                    } else {
+                        Node *right_left = node->right->left;
+                        Node *right =
+                            upd_node(node->right,
+                                     right_left->right,
+                                     node->right->right);
+                        Node *left =
+                            upd_node(node,
+                                     node->left,
+                                     right_left->left);
+                        return upd_node(right_left,
+                                        left,
+                                        right);
+                    }
+                } else {
+                    return node;
+                }
+            }
+        }
+    }
+
+public:
+    interval_map() {
+        root = NULL;
+    }
+
+    V &operator[](interval_t interval)
+    {
+        Node *node;
+        this->root = insert(this->root, interval.first, interval.second, &node);
+        return node->value;
+    }
+
+    V *lookup(interval_t interval)
+    {
+        return lookup(this->root, interval.first, interval.second);
+    }
+
+    size_t size()
+    {
+        return size(root);
+    }
+
+    class iterator {
+        struct Parent {
+            Node *node;
+            Parent *next;
+        };
+
+        Parent *spine;
+
+    public:
+        iterator() {
+            spine = NULL;
+        }
+
+        iterator(Node *node) {
+            spine = NULL;
+            while (node != NULL) {
+                Parent *parent = new Parent;
+                parent->node = node;
+                parent->next = spine;
+                spine = parent;
+                node = node->left;
+            }
+        }
+
+        bool operator ==(const iterator other) const {
+            return this->spine == other.spine;
+        }
+
+        bool operator !=(const iterator other) const {
+            return this->spine != other.spine;
+        }
+
+        std::pair<interval_t,V&> operator *() const {
+            return std::pair<interval_t,V&>
+                              (interval_t(spine->node->start,spine->node->end)
+                              ,spine->node->value
+                              );
+        }
+
+        void operator ++() {
+            Parent *parent = spine->next;
+            Node *node = spine->node->right;
+            delete spine;
+            spine = parent;
+
+            while (node != NULL) {
+                parent = new Parent;
+                parent->node = node;
+                parent->next = spine;
+                spine = parent;
+                node = node->left;
+            }
+        }
+
+        ~iterator() {
+            while (spine != NULL) {
+                Parent *parent = spine->next;
+                delete spine;
+                spine = parent;
+            }
+        }
+    };
+
+    iterator begin() const {
+        return iterator(root);
+    }
+
+    iterator end() const {
+        return iterator();
+    }
+
+    class Overlaps {
+        Node *root;
+        interval_t i;
+
+    public:
+        class iterator {
+            struct Parent {
+                Node *node;
+                Parent *next;
+            };
+
+            Parent *spine;
+            size_t start, end;
+
+        public:
+            iterator() {
+                spine = NULL;
+            }
+
+            iterator(Node *node, size_t start, size_t end) {
+                this->start = start;
+                this->end = end;
+
+                spine = NULL;
+                for (;;) {
+                    Parent *parent;
+                    while (node != NULL && start <= node->max) {
+                        parent = new Parent;
+                        parent->node = node;
+                        parent->next = spine;
+                        spine = parent;
+                        node = node->left;
+                    }
+
+                    if (spine == NULL || (start <= spine->node->end && end >= spine->node->start))
+                        return;
+
+                    parent = spine->next;
+                    node   = spine->node->right;
+                    delete spine;
+                    spine  = parent;
+                }
+            }
+
+            bool operator ==(const iterator other) const {
+                return this->spine == other.spine;
+            }
+
+            bool operator !=(const iterator other) const {
+                return this->spine != other.spine;
+            }
+
+            std::pair<interval_t,V&> operator *() const {
+                return std::pair<interval_t,V&>
+                                  (interval_t(spine->node->start,spine->node->end)
+                                  ,spine->node->value
+                                  );
+            }
+
+            void operator ++() {
+                for (;;) {
+                    Parent *parent = spine->next;
+                    Node *node = spine->node->right;
+                    delete spine;
+                    spine = parent;
+
+                    while (node != NULL && start <= node->max) {
+                        parent = new Parent;
+                        parent->node = node;
+                        parent->next = spine;
+                        spine = parent;
+                        node = node->left;
+                    }
+
+                    if (spine == NULL || (start <= spine->node->end && end >= spine->node->start))
+                        return;
+                }
+            }
+
+            ~iterator() {
+                while (spine != NULL) {
+                    Parent *parent = spine->next;
+                    delete spine;
+                    spine = parent;
+                }
+            }
+        };
+
+        Overlaps(Node *root, interval_t i) {
+            this->root = root;
+            this->i    = i;
+        }
+
+        iterator begin() const {
+            return iterator(root,i.first,i.second);
+        }
+
+        iterator end() const {
+            return iterator();
+        }
+    };
+
+    Overlaps overlaps(interval_t interval)
+    {
+        return Overlaps(this->root, interval);
+    }
+};
+
+#endif

src/runtime/c/pgf/linearizer.cxx

@@ -2,6 +2,44 @@
 #include "printer.h"
 #include "linearizer.h"
 
+bool PgfLinearizer::Item::instantiate(ref<PgfLParam> lparam,size_t value)
+{
+    if (value < lparam->i0)
+        return false;
+    value -= lparam->i0;
+
+    for (size_t j = 0; j < lparam->n_terms; j++) {
+        term t = lparam->terms[j];
+        if (vars[t.var] > 0) {
+            if (value < vars[t.var]-1)
+                return false;
+            value -= vars[t.var]-1;
+        }
+    }
+
+    for (size_t j = 0; j < lparam->n_terms; j++) {
+        term t = lparam->terms[j];
+        if (vars[t.var] == 0) {
+            size_t v_val = value / t.factor;
+            if (v_val >= rule->ranges[t.var])
+                return false;
+            vars[t.var] = v_val + 1;
+            value %= t.factor;
+        }
+    }
+
+    return (value == 0);
+}
+
+size_t PgfLinearizer::Item::eval(ref<PgfLParam> lparam)
+{
+    size_t value = lparam->i0;
+    for (size_t i = 0; i < lparam->n_terms; i++) {
+        value += lparam->terms[i].factor * (vars[lparam->terms[i].var]-1);
+    }
+    return value;
+}
+
 PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
 {
     this->next     = linearizer->prev;
@@ -11,8 +49,6 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
     this->fid       = 0;
 
     this->value     = 0;
-    this->var_count = 0;
-    this->var_values= NULL;
 
     this->n_hoas_vars = 0;
     this->hoas_vars   = NULL;
@@ -20,19 +56,18 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer)
     linearizer->prev = this;
 }
 
-void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r)
+bool PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
 {
     TreeNode *arg = args;
     while (d > 0) {
         arg = arg->next_arg;
-        if (arg == 0)
+        if (arg == NULL)
             break;
         d--;
     }
-    if (arg == 0)
+    if (arg == NULL)
         throw pgf_error("Missing argument");
-    size_t lindex = eval_param(r);
+    return arg->linearize(out, linearizer, r);
-    arg->linearize(out, linearizer, lindex);
 }
 
 void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
@@ -52,20 +87,17 @@ void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, Pg
     out->symbol_token(linearizer->printer.get_text());
 }
 
-void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref<PgfSequence> seq)
+bool PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms)
 {
-    for (size_t i = 0; i < seq->syms.size(); i++) {
+    for (size_t i = 0; i < syms.size(); i++) {
-        PgfSymbol sym = seq->syms[i];
+        PgfSymbol sym = syms[i];
 
         switch (ref<PgfSymbol>::get_tag(sym)) {
         case PgfSymbolCat::tag: {
             auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-            linearize_arg(out, linearizer, sym_cat->d, &sym_cat->r);
+            size_t r = item->eval(ref<PgfLParam>::from_ptr(&sym_cat->r));
-            break;
+            if (!linearize_arg(out, linearizer, sym_cat->d, r))
-        }
+                return false;
-        case PgfSymbolLit::tag: {
-            auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
-            linearize_arg(out, linearizer, sym_lit->d, &sym_lit->r);
             break;
         }
         case PgfSymbolVar::tag: {
@@ -133,6 +165,7 @@ void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, Pg
             PreStack *pre = new PreStack();
             pre->next   = linearizer->pre_stack;
             pre->node   = this;
+            pre->item   = item;
             pre->sym_kp = sym_kp;
             pre->bind   = false;
             pre->capit  = CAPIT_NONE;
@@ -167,125 +200,77 @@ void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, Pg
             break;
         }
     }
-}
 
-size_t PgfLinearizer::TreeNode::eval_param(PgfLParam *param)
+    return true;
-{
-    size_t value = param->i0;
-    for (size_t j = 0; j < param->n_terms; j++) {
-        size_t factor = param->terms[j].factor;
-        size_t var    = param->terms[j].var;
-
-        if (var < var_count && var_values[var] != (size_t) -1) {
-            value += factor * var_values[var];
-        } else {
-            throw pgf_error("Unbound variable in resolving a linearization");
-        }
-    }
-    return value;
 }
 
 PgfLinearizer::TreeLinNode::TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrLin> lin)
   : TreeNode(linearizer)
 {
-    this->lin       = lin;
+    this->lin        = lin;
-    this->lin_index = 0;
+    this->rule_index = 0;
+    this->items = new Item*[lin->lincat->fields.size()]();
 }
 
 bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer)
 {
-    vector<PgfHypo> hypos = lin->absfun->type->hypos;
+    while (rule_index < lin->rules.size()) {
-    size_t n_args = lin->args.size() / lin->res.size();
+        Item *item = new (lin->rules[rule_index]) Item();
-
+        item->rule = lin->rules[rule_index];
-    while (lin_index < lin->res.size()) {
-        size_t offset = lin_index*n_args;
-
-        ref<PgfPResult> pres = lin->res[lin_index];
-
-        // Unbind all variables
-        for (size_t j = 0; j < var_count; j++) {
-            var_values[j] = (size_t) -1;
-        }
 
         int i = 0;
         TreeNode *arg = args;
         while (arg != NULL) {
-            ref<PgfPArg> parg = lin->args.elem(offset+i);
+            if (!item->instantiate(item->rule->args[i], arg->value))
-            arg->check_category(linearizer, &hypos[i].type->name);
+                goto next;
 
-            if (arg->value < parg->param->i0)
+            arg = arg->next_arg;  i++;
-                break;
+        }
 
-            size_t value = arg->value - parg->param->i0;
+        {
-            for (size_t j = 0; j < parg->param->n_terms; j++) {
+            size_t max_value = 1;
-                size_t factor    = parg->param->terms[j].factor;
+            for (size_t i = 0; i < item->vars.size(); i++) {
-                size_t var       = parg->param->terms[j].var;
+                if (item->vars[i] == 0)
-                size_t var_value;
+                    max_value *= item->rule->ranges[i];
-
-                if (var < var_count && var_values[var] != (size_t) -1) {
-                    // The variable already has a value
-                    var_value = var_values[var];
-                } else {
-                    // The variable is not assigned yet
-                    var_value = value / factor;
-
-                    // find the range for the variable
-                    size_t range = 0;
-                    for (size_t k = 0; k < pres->vars.size(); k++) {
-                        ref<PgfVariableRange> var_range = pres->vars.elem(k);
-                        if (var_range->var == var) {
-                            range = var_range->range;
-                            break;
-                        }
-                    }
-                    if (range == 0)
-                        throw pgf_error("Unknown variable in resolving a linearization");
-
-                    if (var_value >= range)
-                        break;
-
-                    // Assign the variable;
-                    if (var >= var_count) {
-                        var_values = (size_t*)
-                            realloc(var_values, (var+1)*sizeof(size_t));
-                        while (var_count < var) {
-                            var_values[var_count++] = (size_t) -1;
-                        }
-                        var_count++;
-                    }
-                    var_values[var] = var_value;
-                }
-
-                value -= var_value * factor;
             }
 
-            if (value != 0)
+            for (size_t value = 0; value < max_value; value++) {
-                break;
+                Item *new_item = new (item) Item;
 
-            arg = arg->next_arg;
+                size_t v = value;
-            i++;
+                for (size_t i = 0; i < new_item->vars.size(); i++) {
+                    if (new_item->vars[i] == 0) {
+                        size_t range = new_item->rule->ranges[i];
+                        new_item->vars[i] = (v % range)+1;
+                        v = v / range;
+                    }
+                }
+
+                size_t lin_idx = new_item->eval(new_item->rule->lin_idx);
+                items[lin_idx] = new_item;
+
+                this->value = new_item->eval(new_item->rule->res);
+            }
         }
+    next:
+        delete item;
 
-        lin_index++;
+        rule_index++;
-
-        if (arg == NULL) {
-            value = eval_param(&pres->param);
-            return true;
-        }
     }
 
-    lin_index = 0;
+    return true;
-    return false;
 }
 
-void PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
+bool PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
 {
-    if (textcmp(&lin->absfun->type->name, cat) != 0)
+    return (textcmp(&lin->absfun->type->name, cat) == 0);
-        throw pgf_error("An attempt to linearize an expression which is not type correct");
 }
 
-void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
+    if (items[lindex] == NULL)
+        return false;
+
     PgfText *cat = &lin->absfun->type->name;
     PgfText *field = &*lin->lincat->fields[lindex];
 
@@ -302,9 +287,9 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf
         linearizer->pre_stack->bracket_stack = bracket;
     }
 
-    size_t n_seqs = lin->seqs.size() / lin->res.size();
+    if (!linearize_item(out, linearizer,
-    ref<PgfSequence> seq = lin->seqs[(lin_index-1)*n_seqs + lindex];
+                        items[lindex],items[lindex]->rule->syms.as_vector()))
-    linearize_seq(out, linearizer, seq);
+        return false;
 
     if (linearizer->pre_stack == NULL)
         out->end_phrase(cat, fid, field, &lin->name);
@@ -318,6 +303,8 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf
         bracket->fun   = &lin->name;
         linearizer->pre_stack->bracket_stack = bracket;
     }
+
+    return true;
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLinNode::get_lincat(PgfLinearizer *linearizer)
@@ -325,11 +312,22 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLinNode::get_lincat(PgfLinearizer *linear
     return namespace_lookup(linearizer->concr->lincats, &lin->absfun->type->name);
 }
 
+PgfLinearizer::TreeLinNode::~TreeLinNode()
+{
+    size_t n_fields = lin->lincat->fields.size();
+    for (size_t i = 0; i < n_fields; i++) {
+        if (items[i] != NULL)
+            delete items[i];
+    }
+    delete[] items;
+};
+
 PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *literal)
   : TreeNode(linearizer)
 {
     this->lincat    = 0;
-    this->lin_index = 0;
+    this->rule_index= 0;
+    this->items     = NULL;
     this->fun       = fun;
     this->literal   = literal;
 
@@ -355,73 +353,106 @@ PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText
 
 bool PgfLinearizer::TreeLindefNode::resolve(PgfLinearizer *linearizer)
 {
-    if (lincat == 0) {
+    if (lincat == 0)
-        return (lin_index = !lin_index);
+        return true;
-    } else {
+
-        ref<PgfPResult> pres = lincat->res[lin_index];
+    while (rule_index < lincat->n_lindefs) {
-        value = eval_param(&pres->param);
+        ref<PgfConcrRule> rule = lincat->rules[rule_index];
-        lin_index++;
+        Item *item = new (rule) Item();
-        if (lin_index <= lincat->n_lindefs)
+        item->rule = rule;
-            return true;
+
-        lin_index = 0;
+        size_t max_value = 1;
-        return false;
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] == 0)
+                max_value *= item->rule->ranges[i];
+        }
+
+        for (size_t value = 0; value < max_value; value++) {
+            Item *new_item = new (item) Item;
+
+            size_t v = value;
+            for (size_t i = 0; i < new_item->vars.size(); i++) {
+                if (new_item->vars[i] == 0) {
+                    size_t range = new_item->rule->ranges[i];
+                    new_item->vars[i] = (v % range)+1;
+                    v = v / range;
+                }
+            }
+
+            size_t lin_idx = new_item->eval(new_item->rule->lin_idx);
+            items[lin_idx] = new_item;
+
+            this->value = new_item->eval(new_item->rule->res);
+        }
+        delete item;
+
+        rule_index++;
     }
+
+    return true;
 }
 
-void PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
+bool PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
 {
     lincat = namespace_lookup(linearizer->concr->lincats, cat);
-    if (lincat == 0)
+    if (lincat != 0)
-        throw pgf_error("Cannot find a lincat for a category");
+        this->items = new Item*[lincat->fields.size()]();
+    return true;
 }
 
-void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r)
+bool PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r)
 {
     linearizer->flush_pre_stack(out, literal);
     out->symbol_token(literal);
 
     TreeNode *arg = args;
     while (arg != NULL) {
-        arg->linearize(out,linearizer,0);
+        if (!arg->linearize(out,linearizer,0))
+            return false;
         arg = arg->next_arg;
     }
+    return true;
 }
 
-void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
-    if (lincat != 0) {
+    if (lincat==0) {
-        PgfText *field = &*lincat->fields[lindex];
+        return linearize_arg(out, linearizer, 0, 0);
-        if (linearizer->pre_stack == NULL)
-            out->begin_phrase(&lincat->name, fid, field, fun);
-        else {
-            BracketStack *bracket = new BracketStack();
-            bracket->next  = linearizer->pre_stack->bracket_stack;
-            bracket->begin = true;
-            bracket->fid   = fid;
-            bracket->cat   = &lincat->name;
-            bracket->field = field;
-            bracket->fun   = fun;
-            linearizer->pre_stack->bracket_stack = bracket;
-        }
-
-        ref<PgfSequence> seq = lincat->seqs[(lin_index-1)*lincat->fields.size() + lindex];
-        linearize_seq(out, linearizer, seq);
-
-        if (linearizer->pre_stack == NULL)
-            out->end_phrase(&lincat->name, fid, field, fun);
-        else {
-            BracketStack *bracket = new BracketStack();
-            bracket->next  = linearizer->pre_stack->bracket_stack;
-            bracket->begin = false;
-            bracket->fid   = fid;
-            bracket->cat   = &lincat->name;
-            bracket->field = field;
-            bracket->fun   = fun;
-            linearizer->pre_stack->bracket_stack = bracket;
-        }
-    } else {
-        linearize_arg(out, linearizer, 0, NULL);
     }
+
+    PgfText *cat = &lincat->name;
+    PgfText *field = &*lincat->fields[lindex];
+
+    if (linearizer->pre_stack == NULL)
+        out->begin_phrase(cat, fid, field, linearizer->wild);
+    else {
+        BracketStack *bracket = new BracketStack();
+        bracket->next  = linearizer->pre_stack->bracket_stack;
+        bracket->begin = true;
+        bracket->fid   = fid;
+        bracket->cat   = cat;
+        bracket->field = field;
+        bracket->fun   = linearizer->wild;
+        linearizer->pre_stack->bracket_stack = bracket;
+    }
+
+    if (!linearize_item(out, linearizer,
+                        items[lindex],items[lindex]->rule->syms.as_vector()))
+        return false;
+
+    if (linearizer->pre_stack == NULL)
+        out->end_phrase(cat, fid, field, linearizer->wild);
+    else {
+        BracketStack *bracket = new BracketStack();
+        bracket->next  = linearizer->pre_stack->bracket_stack;
+        bracket->begin = false;
+        bracket->fid   = fid;
+        bracket->cat   = cat;
+        bracket->field = field;
+        bracket->fun   = linearizer->wild;
+        linearizer->pre_stack->bracket_stack = bracket;
+    }
+    return true;
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *linearizer)
@@ -429,11 +460,27 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *lin
     return lincat;
 }
 
+PgfLinearizer::TreeLindefNode::~TreeLindefNode()
+{
+    if (lincat && items != NULL) {
+        size_t n_fields = lincat->fields.size();
+        for (size_t i = 0; i < n_fields; i++) {
+            if (items[i] != NULL)
+                delete items[i];
+        }
+        delete[] items;
+    }
+
+    free(fun);
+    free(literal);
+};
+
 PgfLinearizer::TreeLinrefNode::TreeLinrefNode(PgfLinearizer *linearizer, TreeNode *root)
   : TreeNode(linearizer)
 {
     args = root;
-    lin_index=0;
+    rule_index=0;
+    item = NULL;
 }
 
 bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer)
@@ -441,83 +488,56 @@ bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer)
     TreeNode *root = args;
     ref<PgfConcrLincat> lincat = root->get_lincat(linearizer);
     if (lincat == 0)
-        return (lin_index = !lin_index);
+        return (rule_index = !rule_index);
 
-    while (lincat->n_lindefs+lin_index < lincat->res.size()) {
+    while (rule_index < lincat->rules.size()) {
-        // Unbind all variables
+        Item *item = new (lincat->rules[lincat->n_lindefs+rule_index]) Item();
-        for (size_t j = 0; j < var_count; j++) {
+        item->rule = lincat->rules[lincat->n_lindefs+rule_index];
-            var_values[j] = (size_t) -1;
+
+        if (!item->instantiate(item->rule->args[0], root->value)) {
+            rule_index++;
+            continue;
         }
 
-        ref<PgfPResult> pres = lincat->res[lincat->n_lindefs+lin_index];
+        size_t max_value = 1;
-        ref<PgfPArg> parg = lincat->args.elem(lincat->n_lindefs+lin_index);
+        for (size_t i = 0; i < item->vars.size(); i++) {
+            if (item->vars[i] == 0)
+                max_value *= item->rule->ranges[i];
+        }
 
-        if (root->value < parg->param->i0)
+        for (size_t value = 0; value < max_value; value++) {
-            break;
+            size_t v = value;
-
+            for (size_t i = 0; i < item->vars.size(); i++) {
-        size_t value = root->value - parg->param->i0;
+                if (item->vars[i] == 0) {
-        for (size_t j = 0; j < parg->param->n_terms; j++) {
+                    size_t range = item->rule->ranges[i];
-            size_t factor    = parg->param->terms[j].factor;
+                    item->vars[i] = v % range;
-            size_t var       = parg->param->terms[j].var;
+                    v = v / range;
-            size_t var_value;
-
-            if (var < var_count && var_values[var] != (size_t) -1) {
-                // The variable already has a value
-                var_value = var_values[var];
-            } else {
-                // The variable is not assigned yet
-                var_value = value / factor;
-
-                // find the range for the variable
-                size_t range = 0;
-                for (size_t k = 0; k < pres->vars.size(); k++) {
-                    ref<PgfVariableRange> var_range = pres->vars.elem(k);
-                    if (var_range->var == var) {
-                        range = var_range->range;
-                        break;
-                    }
                 }
-                if (range == 0)
-                    throw pgf_error("Unknown variable in resolving a linearization");
-
-                if (var_value >= range)
-                    break;
-
-                // Assign the variable;
-                if (var >= var_count) {
-                    var_values = (size_t*)
-                        realloc(var_values, (var+1)*sizeof(size_t));
-                    while (var_count < var) {
-                        var_values[var_count++] = (size_t) -1;
-                    }
-                    var_count++;
-                }
-                var_values[var] = var_value;
             }
 
-            value -= var_value * factor;
+            this->item = new (item) Item;
+            this->value = item->eval(this->item->rule->res);
         }
+        delete item;
 
-        lin_index++;
+        break;
-        if (value == 0) {
-            value = eval_param(&pres->param);
-            return true;
-        }
     }
 
-    lin_index = 0;
+    if (item == NULL) {
-    return false;
+        rule_index = 0;
+        return false;
+    }
+
+    return true;
 }
 
-void PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
     ref<PgfConcrLincat> lincat = args->get_lincat(linearizer);
     if (lincat != 0) {
-        size_t i = lincat->n_lindefs*lincat->fields.size() + (lin_index-1);
+        return linearize_item(out, linearizer, item, item->rule->syms.as_vector());
-        ref<PgfSequence> seq = lincat->seqs[i];
-        linearize_seq(out, linearizer, seq);
     } else {
-        args->linearize(out, linearizer, lindex);
+        return args->linearize(out, linearizer, lindex);
     }
 }
 
@@ -526,6 +546,11 @@ ref<PgfConcrLincat> PgfLinearizer::TreeLinrefNode::get_lincat(PgfLinearizer *lin
     return 0;
 }
 
+PgfLinearizer::TreeLinrefNode::~TreeLinrefNode()
+{
+    delete item;
+}
+
 PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrLincat> lincat, PgfText *lit)
   : TreeNode(linearizer)
 {
@@ -533,13 +558,12 @@ PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrL
     this->literal = lit;
 }
 
-void PgfLinearizer::TreeLitNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
+bool PgfLinearizer::TreeLitNode::check_category(PgfLinearizer *linearizer, PgfText *cat)
 {
-    if (textcmp(&lincat->name, cat) != 0)
+    return (textcmp(&lincat->name, cat) == 0);
-        throw pgf_error("An attempt to linearize an expression which is not type correct");
 }
 
-void PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
+bool PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)
 {
     PgfText *field = NULL;
     if (lincat != 0) {
@@ -553,6 +577,8 @@ void PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, Pgf
     out->symbol_token(literal);
     if (lincat != 0)
         out->end_phrase(&lincat->name, fid, field, linearizer->wild);
+
+    return true;
 }
 
 ref<PgfConcrLincat> PgfLinearizer::TreeLitNode::get_lincat(PgfLinearizer *linearizer)
@@ -570,6 +596,7 @@ PgfLinearizer::PgfLinearizer(PgfPrintContext *ctxt, ref<PgfConcr> concr, PgfMars
     this->args  = NULL;
     this->capit = CAPIT_NONE;
     this->pre_stack = NULL;
+    this->type_error = false;
     this->wild = (PgfText*) malloc(sizeof(PgfText)+2);
     this->wild->size = 1;
     this->wild->text[0] = '_';
@@ -609,6 +636,10 @@ PgfLinearizer::~PgfLinearizer()
 
 bool PgfLinearizer::resolve()
 {
+    if (type_error) {
+        throw pgf_error("An attempt to linearize an expression which is not type correct");
+    }
+
     for (;;) {
         if (!prev || prev->resolve(this)) {
             if (next == NULL)
@@ -663,14 +694,14 @@ void PgfLinearizer::flush_pre_stack(PgfLinearizationOutputIface *out, PgfText *t
                 ref<PgfAlternative> alt = pre->sym_kp->alts.elem(i);
                 for (ref<PgfText> prefix : alt->prefixes) {
                     if (cmp(token, &(*prefix))) {
-                        pre->node->linearize_seq(out, this, alt->form);
+                        pre->node->linearize_item(out, this, pre->item, alt->form);
                         goto done;
                     }
                 }
             }
         }
 
-        pre->node->linearize_seq(out, this, pre->sym_kp->default_form);
+        pre->node->linearize_item(out, this, pre->item, pre->sym_kp->default_form);
 
     done:
         if (pre->bracket_stack != NULL)
@@ -739,9 +770,19 @@ PgfExpr PgfLinearizer::emeta(PgfMetaId meta)
 PgfExpr PgfLinearizer::efun(PgfText *name)
 {
     ref<PgfConcrLin> lin = namespace_lookup(concr->lins, name);
-    if (lin != 0)
+    if (lin != 0) {
+        TreeNode *node = args;
+        size_t i = 0;
+        vector<PgfHypo> hypos = lin->absfun->type->hypos;
+        while (node != NULL) {
+            if (!node->check_category(this, &hypos[i].type->name)) {
+                type_error = true;
+            }
+            node = node->next_arg; i++;
+        }
+
         return (PgfExpr) new TreeLinNode(this, lin);
-    else {
+    } else {
         printer.puts("[");
         printer.efun(name);
         printer.puts("]");

src/runtime/c/pgf/linearizer.h

@@ -26,6 +26,48 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     ref<PgfConcr> concr;
     PgfMarshaller *m;
 
+    struct Item {
+        ref<PgfConcrRule> rule;
+
+        struct {
+            size_t &operator[](int i) {
+                Item *item = containerof(Item,vars,this);
+                return ((size_t*) (item+1))[i];
+            }
+            size_t size() {
+                Item *item = containerof(Item,vars,this);
+                return item->rule->ranges.size();
+            }
+        } vars;
+
+        void *operator new(size_t sz, ref<PgfConcrRule> rule)
+        {
+            size_t sz2 = rule->ranges.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memset(new_item, 0, sz+sz2);
+            return new_item;
+        }
+
+        void *operator new(size_t sz, Item *item)
+        {
+            size_t sz2 = item->vars.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memcpy(new_item, item, sz+sz2);
+            return new_item;
+        }
+
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+        
+        Item() {
+        }
+
+        bool instantiate(ref<PgfLParam> lparam,size_t value);
+        size_t eval(ref<PgfLParam> lparam);
+    };
+
     struct TreeNode {
         TreeNode *next;
         TreeNode *next_arg;
@@ -34,58 +76,60 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         int fid;
 
         size_t value;
-        size_t var_count;
-        size_t *var_values;
 
         size_t n_hoas_vars;
         PgfText **hoas_vars;
 
         TreeNode(PgfLinearizer *linearizer);
         virtual bool resolve(PgfLinearizer *linearizer) { return true; };
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat)=0;
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat)=0;
-        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r);
+        virtual bool linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
         virtual void linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
-        virtual void linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref<PgfSequence> seq);
+        virtual bool linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> syms);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
-        size_t eval_param(PgfLParam *param);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer)=0;
-        virtual ~TreeNode() { free(var_values); free(hoas_vars); };
+        virtual ~TreeNode() { free(hoas_vars); };
     };
 
     struct TreeLinNode : public TreeNode {
         ref<PgfConcrLin> lin;
-        size_t lin_index;
+        size_t rule_index;
+        Item **items;
 
         TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrLin> lin);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
+        virtual ~TreeLinNode();
     };
 
     struct TreeLindefNode : public TreeNode {
         ref<PgfConcrLincat> lincat;
-        size_t lin_index;
+        size_t rule_index;
+        Item **items;
         PgfText *fun;
         PgfText *literal;
 
         TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *lit);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r);
+        virtual bool linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
-        ~TreeLindefNode() { free(fun); free(literal); };
+        ~TreeLindefNode();
     };
 
     struct TreeLinrefNode : public TreeNode {
-        size_t lin_index;
+        size_t rule_index;
+        Item *item;
 
         TreeLinrefNode(PgfLinearizer *linearizer, TreeNode *root);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat) {};
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat) { return true; };
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
+        ~TreeLinrefNode();
     };
 
     struct TreeLitNode : public TreeNode {
@@ -93,8 +137,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
         PgfText *literal;
 
         TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrLincat> lincat, PgfText *lit);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
         ~TreeLitNode() { free(literal); };
     };
@@ -102,8 +146,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     struct TreeChunksNode : public TreeNode {
         TreeChunksNode(PgfLinearizer *linearizer);
         virtual bool resolve(PgfLinearizer *linearizer);
-        virtual void check_category(PgfLinearizer *linearizer, PgfText *cat);
+        virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat);
-        virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
+        virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex);
         virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
     };
 
@@ -129,6 +173,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     struct PreStack {
         PreStack *next;
         TreeNode *node;
+        Item *item;
         ref<PgfSymbolKP> sym_kp;
         bool bind;
         CapitState capit;
@@ -138,6 +183,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
     PreStack *pre_stack;
     void flush_pre_stack(PgfLinearizationOutputIface *out, PgfText *token);
 
+    bool type_error;
     PgfText *wild;
 
 public:
@@ -145,9 +191,11 @@ public:
 
     bool resolve();
     void reverse_and_label(bool add_linref);
-    void linearize(PgfLinearizationOutputIface *out, size_t lindex) {
+    bool linearize(PgfLinearizationOutputIface *out, size_t lindex) {
-        prev->linearize(out, this, lindex);
+        if (!prev->linearize(out, this, lindex))
+            return false;
         flush_pre_stack(out, NULL);
+        return true;
     }
     ref<PgfConcrLincat> get_lincat() {
         return prev->get_lincat(this);

src/runtime/c/pgf/parser.h

@@ -1,191 +1,356 @@
 #ifndef LR_TABLE_H
 #define LR_TABLE_H
 
-#include "md5.h"
-
-class PGF_INTERNAL_DECL PgfLRTableMaker
-{
-    struct CCat;
-    struct Production;
-    struct Item;
-    struct State;
-
-    struct CompareItem;
-    static const CompareItem compare_item;
-
-    typedef std::pair<ref<PgfText>,size_t> Key0;
-
-    struct PGF_INTERNAL_DECL CompareKey0 : std::less<Key0> {
-        bool operator() (const Key0& k1, const Key0& k2) const {
-            int cmp = textcmp(k1.first,k2.first);
-            if (cmp < 0)
-                return true;
-            else if (cmp > 0)
-                return false;
-
-            return (k1.second < k2.second);
-        }
-    };
-
-    typedef std::pair<ref<PgfConcrLincat>,size_t> Key1;
-
-    struct PGF_INTERNAL_DECL CompareKey1 : std::less<Key1> {
-        bool operator() (const Key1& k1, const Key1& k2) const {
-            if (k1.first < k2.first)
-                return true;
-            else if (k1.first > k2.first)
-                return false;
-
-            return (k1.second < k2.second);
-        }
-    };
-
-    typedef std::pair<CCat*,size_t> Key2;
-
-    struct PGF_INTERNAL_DECL CompareKey2 : std::less<Key2> {
-        bool operator() (const Key2& k1, const Key2& k2) const {
-            if (k1.first < k2.first)
-                return true;
-            else if (k1.first > k2.first)
-                return false;
-
-            return (k1.second < k2.second);
-        }
-    };
-
-    typedef std::pair<ref<PgfSequence>,size_t> Key3;
-
-    struct PGF_INTERNAL_DECL CompareKey3 : std::less<Key3> {
-        bool operator() (const Key3& k1, const Key3& k2) const;
-    };
-
-    ref<PgfAbstr> abstr;
-    ref<PgfConcr> concr;
-
-    size_t ccat_id;
-    size_t state_id;
-
-    std::queue<State*> todo;
-    std::map<MD5Digest,State*> states;
-    std::map<Key0,CCat*,CompareKey0> ccats1;
-    std::map<Key2,CCat*,CompareKey2> ccats2;
-
-    // The Threefold Way of building an automaton
-    typedef enum { INIT, PROBE, REPEAT } Fold;
-
-    void process(State *state, Fold fold, Item *item);
-    void symbol(State *state, Fold fold, Item *item, PgfSymbol sym);
-
-    template<class T>
-    void predict(State *state, Fold fold, Item *item, T cat,
-                 vector<PgfVariableRange> vars, PgfLParam *r);
-    void predict(State *state, Fold fold, Item *item, ref<PgfText> cat, size_t lin_idx);
-    void predict(State *state, Fold fold, Item *item, CCat *ccat, size_t lin_idx);
-    void predict(ref<PgfAbsFun> absfun, CCat *ccat);
-    void complete(State *state, Fold fold, Item *item);
-
-    void print_production(CCat *ccat, Production *prod);
-    void print_item(Item *item);
-
-    void internalize_state(State *&state);
-
-public:
-    PgfLRTableMaker(ref<PgfAbstr> abstr, ref<PgfConcr> concr);
-    vector<PgfLRState> make();
-    ~PgfLRTableMaker();
-};
-
-class PGF_INTERNAL_DECL PgfLCTableMaker
-{
-    ref<PgfAbstr> abstr;
-    ref<PgfConcr> concr;
-
-
-    std::map<ref<PgfConcrLincat>,std::vector<ref<PgfLCEdge>>> forwards;
-    std::map<ref<PgfConcrLincat>,std::vector<ref<PgfLCEdge>>> backwards;
-
-    ref<PgfLCEdge> compute_unifier(ref<PgfLCEdge> edge1, ref<PgfLCEdge> edge2);
-    void update_closure(ref<PgfLCEdge> edge);
-    void rename(ref<PgfLCEdge> edge);
-    void add_edge(ref<PgfLCEdge> edge);
-    void print_edge(ref<PgfLCEdge> edge);
-
-public:
-    PgfLCTableMaker(ref<PgfAbstr> abstr, ref<PgfConcr> concr);
-    vector<PgfLRState> make();
-    ~PgfLCTableMaker();
-};
-
 class PgfPrinter;
 
-class PGF_INTERNAL_DECL PgfParser : public PgfPhraseScanner, public PgfExprEnum
+class PGF_INTERNAL_DECL PgfAbstractParser
 {
-    ref<PgfConcr> concr;
+    typedef size_t hash_t;
-    PgfText *sentence;
-    bool case_sensitive;
-    PgfMarshaller *m;
-    PgfUnmarshaller *u;
 
-    struct Choice;
+protected:
-    struct Production;
+    ref<PgfConcr> concr;
-    struct StackNode;
+
-    struct Stage;
+    struct CCat;
+    struct Cont;
+    struct Item;
+    struct State;
     struct ExprState;
-    struct ExprInstance;
+
-    struct CompareExprState : std::less<ExprState*> {
+    struct Production {
-        bool operator() (const ExprState *state1, const ExprState *state2) const;
+        ref<PgfConcrRule> rule;
+
+        struct {
+            size_t &operator[](int i) const {
+                Production *prod = containerof(Production,vars,this);
+                return ((size_t*) (((CCat**) (prod+1))+prod->args.size()))[i];
+            }
+            size_t size() const {
+                Production *prod = containerof(Production,vars,this);
+                return prod->rule->ranges.size();
+            }
+        } vars;
+
+        struct {
+            CCat *&operator[](int i) const {
+                Production *prod = containerof(Production,args,this);
+                return ((CCat**) (prod+1))[i];
+            }
+            size_t size() const {
+                Production *prod = containerof(Production,args,this);
+                return (prod->rule->args != 0) ? prod->rule->args.size() : 0;
+            }
+        } args;
+
+        void *operator new(size_t sz, Item *item)
+        {
+            size_t sz2 = item->args.size()*sizeof(CCat*)
+                       + item->vars.size()*sizeof(size_t);
+            Production *prod = (Production *) malloc(sz+sz2);
+            memcpy(prod+1, item+1, sz2);
+            return prod;
+        }
+
+        void *operator new(size_t sz, ref<PgfItem> pitem)
+        {
+            size_t sz2 = pitem->args.size()*sizeof(CCat*)
+                       + pitem->vars.size()*sizeof(size_t);
+            Production *prod = (Production *) malloc(sz+sz2);
+            memset(prod+1,0,sz2);
+            return prod;
+        }
+
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+
+        Production() {
+        }
     };
 
-    Stage *before, *after, *ahead;
+    struct ExprProb {
-    std::priority_queue<ExprState*, std::vector<ExprState*>, CompareExprState> queue;
+        PgfExpr expr;
-    int last_fid;
+        prob_t prob;
+        hash_t hash;
+        
+        ExprProb(PgfExpr expr, prob_t prob, hash_t hash) {
+            this->expr = expr;
+            this->prob = prob;
+            this->hash = hash;
+        }
+    };
 
-    std::vector<Choice*> dynamic;
+    struct CCat {
-    std::map<object,Choice*> persistant;
+        PgfMetaId fid;
+        ref<PgfCCat> epsilon;
+        Cont *cont;
+        State *state;
+        interval_t value;
+        interval_t lin_idx;
+        prob_t viterbi_prob;
+        bool covered;
+        std::vector<Production*> prods;
+        std::vector<ExprState*> pending;
+        std::vector<ExprProb> exprs;
 
-    std::vector<PgfExpr> exprs;
+        ~CCat();
+    };
 
-    Choice *top_choice;
+    struct State {
-    size_t top_choice_index;
+        PgfTextSpot start, end;
+        bool needs_bind;
+        bool did_bu_predict;
+        std::map<ref<PgfConcrLincat>,Cont*> conts1;
+        std::map<CCat*,Cont*> conts2;
+        std::map<Cont*,interval_map<interval_map<CCat*>>> completed;
+        std::vector<Item*> queue;
+        prob_t viterbi_prob;
 
-    bool shift(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r, Production *prod,
+        State *next;
-               Stage *before, Stage *after);
-    void shift(StackNode *parent, Stage *before);
-    void shift(StackNode *parent, Stage *before, Stage *after);
-    void reduce(StackNode *parent, ref<PgfConcrLin> lin, ref<PgfLRReduce> red,
-                size_t n, std::vector<Choice*> &args,
-                Stage *before, Stage *after);
-    Choice *retrieve_choice(ref<PgfLRReduceArg> arg);
-    void complete(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r,
-                  size_t n, std::vector<Choice*> &args);
-    void reduce_all(StackNode *state);
-    void print_prod(Choice *choice, Production *prod);
-    void print_transition(StackNode *source, StackNode *target, Stage *stage, ref<PgfLRShiftKS> shift);
 
-    typedef std::map<std::pair<Choice*,Choice*>,Choice*> intersection_map;
+        bool has_items() {
+            return queue.size() > 0;
+        }
 
-    Choice *intersect_choice(Choice *choice1, Choice *choice2, intersection_map &im);
+        void push_item(Item *item) {
+            queue.push_back(item);
+            std::push_heap(queue.begin(), queue.end(), item_prob_comp);
+        }
 
-    void print_expr_state_before(PgfPrinter *printer, ExprState *state);
+        Item *pop_item() {
-    void print_expr_state_after(PgfPrinter *printer, ExprState *state);
+            Item *item = queue.front();
-    void print_expr_state(ExprState *state);
+            std::pop_heap(queue.begin(), queue.end(), item_prob_comp);
+            queue.pop_back();
+            return item;
+        }
+    };
 
-    void predict_expr_states(Choice *choice, prob_t outside_prob);
+    static struct ItemProbComparator : std::less<Item*> {
-    bool process_expr_state(ExprState *state);
+        bool operator()(Item *item1, Item *item2) {
-    void complete_expr_state(ExprState *state);
+            return item1->inside_prob+item1->outside_prob > item2->inside_prob+item2->outside_prob;
-    void combine_expr_state(ExprState *state, ExprInstance &inst);
+        }
+    } item_prob_comp;
+
+    struct ItemComparator : std::less<Item*> {
+        bool operator()(Item *item1, Item *item2) const;
+    };
+
+    struct Cont {
+        CCat *ccat;
+        ref<PgfConcrLincat> lincat;
+        State *state;
+        interval_map<interval_map<std::vector<Item*>>> suspended;
+        std::set<Item*,ItemComparator> predicted;
+
+        ~Cont();
+    };
+
+    struct Item {
+        Cont *cont;
+        uint16_t pre_alt;
+        uint16_t pre_dot;
+        uint16_t dot;
+        vector<PgfSymbol> syms;
+        ref<PgfConcrRule> rule;
+        prob_t inside_prob;
+        prob_t outside_prob;
+
+        struct {
+            size_t &operator[](int i) const {
+                Item *item = containerof(Item,vars,this);
+                return ((size_t*) (((CCat**) (item+1))+item->args.size()))[i];
+            }
+            size_t size() const {
+                Item *item = containerof(Item,vars,this);
+                return item->rule->ranges.size();
+            }
+        } vars;
+
+        struct {
+            CCat *&operator[](int i) const {
+                Item *item = containerof(Item,args,this);
+                return ((CCat**) (item+1))[i];
+            }
+            size_t size() const {
+                Item *item = containerof(Item,args,this);
+                return (item->rule->args != 0) ? item->rule->args.size() : 0;
+            }
+        } args;
+
+        void *operator new(size_t sz, ref<PgfConcrRule> rule)
+        {
+            size_t sz2 = rule->args.size()*sizeof(CCat*)
+                       + rule->ranges.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memset(new_item+1, 0, sz2);
+            return new_item;
+        }
+
+        void *operator new(size_t sz, Item *item)
+        {
+            size_t sz2 = item->args.size()*sizeof(CCat*)
+                       + item->vars.size()*sizeof(size_t);
+            Item *new_item = (Item *) malloc(sz+sz2);
+            memcpy(new_item, item, sz+sz2);
+            return new_item;
+        }
+
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+        
+        Item() {
+        }
+    };
+
+    struct ExprState {
+        PgfExpr expr;
+        prob_t prob;
+        hash_t hash;
+
+        CCat *res;
+
+        size_t index;
+        size_t n_args;
+        CCat *args[];
+
+        void *operator new(size_t sz, size_t n_args)
+        {
+            ExprState *estate = (ExprState *)
+                malloc(sz+n_args*sizeof(CCat*));
+            return estate;
+        }
+        
+        void operator delete(void *p)
+        {
+            free(p);
+        }
+
+        ExprState() {
+        }
+    };
+
+    State *current_state;
+    std::map<PgfMetaId,CCat*> epsilons;
+    PgfMetaId initial_fid, last_fid;
+
+    void process(Item *item, State *state);
+    void symbol(Item *item, State *state, PgfSymbol sym);
+    void complete(Item *item, State *state);
+
+    virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob)=0;
+    virtual void symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks)=0;
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym)=0;
+    virtual void suspend(Cont *cont, Item *item, bool do_predict, ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i)=0;
+    virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx)=0;
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat)=0;
+
+    void td_epsilon(State *state, Cont *cont, ref<PgfItem> pitem, Item *xitem, ref<PgfSymbolCat> symcat);
+    void td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfSymbolCat> symcat);
+    void combine(State *state, Item *item, CCat *ccat);
+
+    static
+    bool instantiate(ref<PgfConcrRule> rule1, size_t *values1, ref<PgfLParam> lparam1,
+                     ref<PgfConcrRule> rule2, size_t *values2, ref<PgfLParam> lparam2);
+
+    static
+    interval_t interval(ref<PgfConcrRule> rule, size_t *values, ref<PgfLParam> lparam);
+
+    bool get_info(CCat *ccat, ref<PgfConcrRule> *rule, size_t **pvalues);
+    CCat *get_epsilon_ccat(PgfText *name, PgfMetaId fid);
+
+    static
+    void print_item(Item *item, State *state);
+
+    static
+    void print_prod(CCat *ccat, Production *prod);
 
 public:
-    PgfParser(ref<PgfConcr> concr, ref<PgfConcrLincat> start, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u);
+    PgfAbstractParser(ref<PgfConcr> concr);
+    virtual ~PgfAbstractParser();
+};
+
+class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnum, public PgfParseChart
+{
+    PgfMarshaller *m;
+    PgfUnmarshaller *u;
+    PgfText *sentence;
+    bool case_sensitive;
+
+    // The following are used only during chart updates.
+    State *prev_state;
+    size_t update_old_pos, update_new_pos;
+    ssize_t delta_byte_pos;
+    ssize_t allocated_size;
+
+    void perform_search();
+
+    virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob);
+    virtual void symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks);
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
+    virtual void suspend(Cont *cont,Item *item,bool do_predict,ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i);
+    virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat);
+
+    void bu_predict(PgfPhrasetable<PgfSymbolBIND> phrasetable, State *state, prob_t outside_prob);
+    void bu_literal(State *state, const char *name, PgfExprParser *eparser, prob_t viterbi_prob);
+    void bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable, State *state, prob_t outside_prob, ptrdiff_t min, ptrdiff_t max);
+    void make_chunks(State *state, std::vector<CCat*> &chunks, prob_t prob);
+    PgfExpr process_expr(ExprState *estate, prob_t *prob);
+
+    bool td_reachable(State *state, ref<PgfItem> pitem, std::map<ref<PgfConcrLincat>, bool> &visited);
+    Item *bu_item(State *state, prob_t outside_prob, ref<PgfItem> pitem);
+
+    static
+    void print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate);
+    static
+    void print_expr_state_right(PgfPrinter *printer, ExprState *estate);
+    static
+    void print_expr_state(PgfMarshaller *m, ExprState *estate);
+
+    static struct ExprStateComparator : std::less<ExprState*> {
+        bool operator()(ExprState *estate1, ExprState *estate2) {
+            return estate1->prob > estate2->prob;
+        }
+    } estate_comp;
+
+    std::vector<ExprState*> queue;
+
+public:
+    PgfParser(ref<PgfConcr> concr, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u);
     virtual ~PgfParser();
 
-	virtual void space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err);
+    bool prepare(ref<PgfConcrLincat> start, bool robust);
-    virtual void start_matches(PgfTextSpot *end, PgfExn* err);
+    size_t get_end_pos() { return current_state->end.pos; }
-    virtual void match(ref<PgfConcrLin> lin, size_t seq_index, PgfExn* err);
-	virtual void end_matches(PgfTextSpot *end, PgfExn* err);
 
-    void prepare();
+    virtual PgfExpr fetch(PgfDB *db, prob_t *prob);
 
-    PgfExpr fetch(PgfDB *db, prob_t *prob);
+    virtual PgfText *get_text();
+    virtual void start();
+    virtual bool skip(size_t i);
+    virtual bool change(size_t i, PgfText *change);
+    virtual void done();
 };
+
+class PGF_INTERNAL_DECL PgfParseTableMaker : private PgfAbstractParser
+{
+private:
+    virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob);
+    virtual void symbol_token(Item *item, State *state, ref<PgfSymbolKS> symks);
+    virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
+    virtual void suspend(Cont *cont, Item *item, bool do_predict, ref<PgfSymbolCat> symcat,interval_t value_i,interval_t lin_idx_i);
+    virtual void final_item(State *state, CCat *ccat,Item *item,interval_t value,interval_t lin_idx);
+    virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat);
+
+    static
+    ref<PgfItem> clone_item(Item *item);
+
+public:
+    PgfParseTableMaker(ref<PgfConcr> concr);
+    void insert_rule(ref<PgfConcrRule> rule);
+    void prepare();
+    PgfMetaId get_last_fid() { return last_fid; };
+};
+
 #endif

src/runtime/c/pgf/pgf.h

@@ -76,6 +76,7 @@ typedef enum {
     PGF_EXN_SYSTEM_ERROR,
     PGF_EXN_PGF_ERROR,
     PGF_EXN_TYPE_ERROR,
+    PGF_EXN_PARSE_ERROR,
     PGF_EXN_OTHER_ERROR
 }  PgfExnType;
 
@@ -461,8 +462,6 @@ PGF_API_DECL
 void pgf_iter_lins(PgfDB *db, PgfConcrRevision cnc_revision,
                    PgfItor *itor, PgfExn *err);
 
-typedef struct PgfPhrasetableIds PgfPhrasetableIds;
-
 typedef struct PgfSequenceItor PgfSequenceItor;
 struct PgfSequenceItor {
 	int (*fn)(PgfSequenceItor* self, size_t seq_id, object value,
@@ -493,10 +492,10 @@ void pgf_lookup_cohorts(PgfDB *db, PgfConcrRevision cnc_revision,
                         PgfCohortsCallback* callback, PgfExn* err);
 
 PGF_API_DECL
-PgfPhrasetableIds *pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision,
+void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision,
-                                      PgfSequenceItor *itor,
+                        PgfSequenceItor *itor,
-                                      PgfMorphoCallback *callback,
+                        PgfMorphoCallback *callback,
-                                      PgfExn *err);
+                        PgfExn *err);
 
 PGF_API_DECL
 void pgf_get_lincat_counts_internal(object o, size_t *counts);
@@ -505,26 +504,20 @@ PGF_API_DECL
 PgfText *pgf_get_lincat_field_internal(object o, size_t i);
 
 PGF_API_DECL
-size_t pgf_get_lin_get_prod_count(object o);
+size_t pgf_get_lin_rules_count(object o);
 
 PGF_API_DECL
-PgfText *pgf_print_lindef_internal(PgfPhrasetableIds *seq_ids, object o, size_t i);
+PgfText *pgf_print_lindef_internal(object o, size_t i);
 
 PGF_API_DECL
-PgfText *pgf_print_linref_internal(PgfPhrasetableIds *seq_ids, object o, size_t i);
+PgfText *pgf_print_linref_internal(object o, size_t i);
 
 PGF_API_DECL
-PgfText *pgf_print_lin_internal(PgfPhrasetableIds *seq_ids, object o, size_t i);
+PgfText *pgf_print_lin_internal(object o, size_t i);
-
-PGF_API_DECL
-PgfText *pgf_print_sequence_internal(size_t seq_id, object o);
 
 PGF_API_DECL
 PgfText *pgf_sequence_get_text_internal(object o);
 
-PGF_API_DECL
-void pgf_release_phrasetable_ids(PgfPhrasetableIds *seq_ids);
-
 PGF_API_DECL
 PgfExpr pgf_check_expr(PgfDB *db, PgfRevision revision,
                        PgfExpr e, PgfType ty,
@@ -620,14 +613,19 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision,
 
 PGF_API_DECL
 PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
-                                     PgfText *name,
+                                     PgfText *name, void **p_tm,
                                      PgfExn *err);
 
 PGF_API_DECL
 PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
-                                    PgfText *name,
+                                    PgfText *name, void **p_tm,
                                     PgfExn *err);
 
+PGF_API_DECL
+void pgf_free_parse_table(PgfDB *db,
+                          PgfRevision revision, PgfConcrRevision cnc_revision,
+                          void *table_maker);
+
 PGF_API_DECL
 void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
                        PgfText *name,
@@ -635,13 +633,12 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
 
 #ifdef __cplusplus
 struct PgfLinBuilderIface {
-    virtual void start_production(PgfExn *err)=0;
+    virtual void start_rule(size_t n_vars, size_t n_syms, PgfExn *err)=0;
-    virtual void add_argument(size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
-    virtual void set_result(size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
+    virtual void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
-    virtual void add_variable(size_t var, size_t range, PgfExn *err)=0;
+    virtual void set_lin_idx(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
-    virtual void start_sequence(size_t n_syms, PgfExn *err)=0;
+    virtual void add_variable(size_t range, PgfExn *err)=0;
     virtual void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
-    virtual void add_symlit(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0;
     virtual void add_symvar(size_t d, size_t r, PgfExn *err)=0;
     virtual void add_symks(PgfText *token, PgfExn *err)=0;
     virtual void start_symkp(size_t n_syms, size_t n_alts, PgfExn *err)=0;
@@ -654,9 +651,7 @@ struct PgfLinBuilderIface {
     virtual void add_symsoftspace(PgfExn *err)=0;
     virtual void add_symcapit(PgfExn *err)=0;
     virtual void add_symallcapit(PgfExn *err)=0;
-    virtual object end_sequence(PgfExn *err)=0;
+    virtual void end_rule(PgfExn *err)=0;
-    virtual void add_sequence_id(object seq_id, PgfExn *err)=0;
-    virtual void end_production(PgfExn *err)=0;
 };
 
 struct PgfBuildLinIface {
@@ -666,13 +661,12 @@ struct PgfBuildLinIface {
 typedef struct PgfLinBuilderIface PgfLinBuilderIface;
 
 typedef struct {
-    void (*start_production)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*start_rule)(PgfLinBuilderIface *this, size_t n_vars, size_t n_syms, PgfExn *err);
-    void (*add_argument)(PgfLinBuilderIface *this, size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*add_argument)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
-    void (*set_result)(PgfLinBuilderIface *this, size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
+    void (*set_result)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
-    void (*add_variable)(PgfLinBuilderIface *this, size_t var, size_t range, PgfExn *err);
+    void (*set_lin_idx)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
-    void (*start_sequence)(PgfLinBuilderIface *this, size_t n_syms, PgfExn *err);
+    void (*add_variable)(PgfLinBuilderIface *this, size_t range, PgfExn *err);
     void (*add_symcat)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
-    void (*add_symlit)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err);
     void (*add_symvar)(PgfLinBuilderIface *this, size_t d, size_t r, PgfExn *err);
     void (*add_symks)(PgfLinBuilderIface *this, PgfText *token, PgfExn *err);
     void (*start_symkp)(PgfLinBuilderIface *this, size_t n_syms, size_t n_alts, PgfExn *err);
@@ -685,9 +679,7 @@ typedef struct {
     void (*add_symsoftspace)(PgfLinBuilderIface *this, PgfExn *err);
     void (*add_symcapit)(PgfLinBuilderIface *this, PgfExn *err);
     void (*add_symallcapit)(PgfLinBuilderIface *this, PgfExn *err);
-    object (*end_sequence)(PgfLinBuilderIface *this, PgfExn *err);
+    void (*end_rule)(PgfLinBuilderIface *this, PgfExn *err);
-    void (*add_sequence_id)(PgfLinBuilderIface *this, object seq_id, PgfExn *err);
-    void (*end_production)(PgfLinBuilderIface *this, PgfExn *err);
 } PgfLinBuilderIfaceVtbl;
 
 struct PgfLinBuilderIface {
@@ -708,6 +700,7 @@ struct PgfBuildLinIface {
 PGF_API_DECL
 void pgf_create_lincat(PgfDB *db,
                        PgfRevision revision, PgfConcrRevision cnc_revision,
+                       void *table_maker,
                        PgfText *name, size_t n_fields, PgfText **fields,
                        size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build,
                        PgfExn *err);
@@ -720,10 +713,19 @@ void pgf_drop_lincat(PgfDB *db,
 PGF_API_DECL
 void pgf_create_lin(PgfDB *db,
                     PgfRevision revision, PgfConcrRevision cnc_revision,
-                    PgfText *name, size_t n_prods,
+                    void *table_maker,
+                    PgfText *name, size_t n_rules,
                     PgfBuildLinIface *build,
                     PgfExn *err);
 
+PGF_API_DECL
+void pgf_alter_lin(PgfDB *db,
+                   PgfRevision revision, PgfConcrRevision cnc_revision,
+                   void *table_maker,
+                   PgfText *name, size_t n_rules,
+                   PgfBuildLinIface *build,
+                   PgfExn *err);
+
 PGF_API_DECL
 void pgf_drop_lin(PgfDB *db,
                   PgfRevision revision, PgfConcrRevision cnc_revision,
@@ -821,12 +823,45 @@ void pgf_bracketed_linearize_all(PgfDB *db, PgfConcrRevision revision,
 PGF_API_DECL
 PgfExprEnum *pgf_parse(PgfDB *db, PgfConcrRevision revision,
                        PgfType ty, PgfMarshaller *m, PgfUnmarshaller *u,
-                       PgfText *sentence,
+                       PgfText *sentence, int robust,
                        PgfExn * err);
 
 PGF_API_DECL
 void pgf_free_expr_enum(PgfExprEnum *en);
 
+#ifdef __cplusplus
+struct PgfParseChart {
+    virtual PgfText *get_text()=0;
+    virtual void start()=0;
+    virtual bool skip(size_t i)=0;
+    virtual bool change(size_t i, PgfText *change)=0;
+    virtual void done()=0;
+    virtual ~PgfParseChart() {};
+};
+#else
+typedef struct PgfParseChart PgfParseChart;
+typedef struct PgfParseChartVtbl PgfParseChartVtbl;
+struct PgfParseChartVtbl {
+    PgfText *(*get_text)(PgfParseChart *this);
+    void (*start)(PgfParseChart *this);
+    int (*skip)(PgfParseChart *this, size_t i);
+    int (*change)(PgfParseChart *this, size_t i, PgfText *change);
+    void (*done)(PgfParseChart *this);
+};
+struct PgfParseChart {
+    PgfParseChartVtbl *vtbl;
+};
+#endif
+
+PGF_API_DECL
+PgfParseChart *pgf_parse_chart(PgfDB *db, PgfConcrRevision revision,
+                               PgfType ty, PgfMarshaller *m, PgfUnmarshaller *u,
+                               PgfText *sentence, int robust,
+                               PgfExn * err);
+
+PGF_API_DECL
+void pgf_free_parse_chart(PgfParseChart *chart);
+
 PGF_API_DECL
 PgfText *pgf_get_printname(PgfDB *db, PgfConcrRevision revision,
                            PgfText *fun, PgfExn* err);
@@ -916,8 +951,4 @@ pgf_align_words(PgfDB *db, PgfConcrRevision revision,
                 size_t *n_phrases /* out */,
                 PgfExn* err);
 
-PGF_API PgfText *
-pgf_graphviz_lr_automaton(PgfDB *db, PgfConcrRevision revision,
-                          PgfExn *err);
-
 #endif // PGF_H_

src/runtime/c/pgf/phrasetable.h

@@ -1,138 +1,153 @@
 #ifndef PHRASETABLE_H
 #define PHRASETABLE_H
 
-struct PgfSequence;
-struct PgfSequenceBackref;
-
-struct PGF_INTERNAL_DECL PgfPhrasetableEntry {
-    ref<PgfSequence> seq;
-
-    // Here n_backrefs tells us how many actual backrefs there are in
-    // the vector backrefs. On the other hand, backrefs->len tells us
-    // how big buffer we have allocated.
-    size_t n_backrefs;
-    vector<PgfSequenceBackref> backrefs;
-};
-
-struct PgfSequenceItor;
-typedef ref<Node<PgfPhrasetableEntry>> PgfPhrasetable;
-
-
-#if __GNUC__
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wattributes"
-#endif
-
-struct PgfPhrasetableIds {
-public:
-	PGF_INTERNAL_DECL PgfPhrasetableIds();
-	PGF_INTERNAL_DECL ~PgfPhrasetableIds() { end(); }
-
-	PGF_INTERNAL_DECL void start(ref<PgfConcr> concr);
-	PGF_INTERNAL_DECL size_t add(ref<PgfSequence> seq);
-	PGF_INTERNAL_DECL size_t get(ref<PgfSequence> seq);
-	PGF_INTERNAL_DECL void end();
-
-private:
-	size_t next_id;
-
-	struct PGF_INTERNAL_DECL SeqIdChain;
-
-	struct PGF_INTERNAL_DECL SeqIdPair {
-		SeqIdChain *chain;
-		ref<PgfSequence> seq;
-		size_t seq_id;
-	};
-
-	struct PGF_INTERNAL_DECL SeqIdChain : public SeqIdPair {
-		SeqIdChain *next;
-	};
-
-	size_t n_pairs;
-	SeqIdPair  *pairs;
-	SeqIdChain *chains;
-};
-
-#if __GNUC__
-#pragma GCC diagnostic pop
-#endif
-
-struct PgfConcrLincat;
-
-PGF_INTERNAL_DECL
-PgfPhrasetable phrasetable_internalize(PgfPhrasetable table,
-                                       ref<PgfSequence> seq,
-                                       ref<PgfConcrLincat> lincat,
-                                       object container,
-                                       size_t seq_index,
-                                       ref<PgfPhrasetableEntry> *pentry);
-
-PGF_INTERNAL_DECL
-ref<PgfSequence> phrasetable_relink(PgfPhrasetable table,
-                                    object container,
-                                    size_t seq_index,
-                                    size_t seq_id);
-
-PGF_INTERNAL_DECL
-PgfPhrasetable phrasetable_delete(PgfPhrasetable table,
-                                  object container,
-                                  size_t seq_index,
-                                  ref<PgfSequence> seq);
-
-PGF_INTERNAL_DECL
-size_t phrasetable_size(PgfPhrasetable table);
-
 struct PgfConcrLin;
+struct PgfConcrLincat;
 
 struct PGF_INTERNAL_DECL PgfTextSpot {
 	size_t pos;          // position in Unicode characters
-	const uint8_t *ptr;  // pointer into the spot location
+	size_t byte_pos;     // position in number of bytes
 };
 
+struct PGF_INTERNAL_DECL PgfItem {
+    PgfMetaId res;
+
+    struct {
+        size_t &operator[](int i) {
+            PgfItem *item = containerof(PgfItem,vars,this);
+            return ((size_t*) (((PgfMetaId*) (item+1))+item->rule->args.size()))[i];
+        }
+        size_t size() {
+            PgfItem *item = containerof(PgfItem,vars,this);
+            return (item->rule->ranges != 0) ? item->rule->ranges.size() : 0;
+        }
+    } vars;
+
+    struct {
+        PgfMetaId &operator[](int i) {
+            PgfItem *item = containerof(PgfItem,args,this);
+            return ((PgfMetaId*) (item+1))[i];
+        }
+        size_t size() {
+            PgfItem *item = containerof(PgfItem,args,this);
+            return item->rule->args.size();
+        }
+    } args;
+
+    static
+    void release(ref<PgfItem> item) {
+        size_t ex_size =
+            sizeof(PgfMetaId) * item->args.size() +
+            sizeof(size_t)    * item->vars.size();
+        PgfDB::free(item, ex_size);
+    }
+
+    uint16_t pre_alt;
+    uint16_t pre_dot;
+    uint16_t dot;
+    ref<PgfConcrRule> rule;
+};
+
+struct PGF_INTERNAL_DECL PgfCCat {
+    ref<PgfConcrLincat> lincat;
+    PgfMetaId prev_fid, fid;
+    interval_t value, lin_idx;
+    prob_t viterbi_prob;
+
+    // Here n_items tells us how many actual items there are in
+    // the vector items. On the other hand, items.size() tells us
+    // how big buffer we have allocated.
+    size_t n_items;
+    vector<ref<PgfItem>> items;
+};
+
+template<class K>
+struct PGF_INTERNAL_DECL PgfPhrasetableValue {
+    ref<K> key;
+
+    // Here n_items tells us how many actual items there are in
+    // the vector items. On the other hand, items.size() tells us
+    // how big buffer we have allocated.
+    size_t n_items;
+    vector<ref<PgfItem>> items;
+};
+
+template <class K>
+using PgfPhrasetable = ref<Node<PgfPhrasetableValue<K>>>;
+
+template<class K>
+PGF_INTERNAL_DECL
+PgfPhrasetable<K> phrasetable_insert(PgfPhrasetable<K> table,
+                                     ref<K> key, ref<PgfItem> item);
+
+template<class K>
+PGF_INTERNAL_DECL
+vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<K> phrasetable,
+                                        ref<K> key,
+                                        size_t *n_items);
+
 class PGF_INTERNAL_DECL PgfPhraseScanner {
 public:
     virtual void space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err)=0;
     virtual void start_matches(PgfTextSpot *spot, PgfExn* err)=0;
-    virtual void match(ref<PgfConcrLin> lin, size_t seq_index, PgfExn* err)=0;
+    virtual void match(ref<PgfConcrLin> lin, size_t lin_idx, PgfExn* err)=0;
     virtual void end_matches(PgfTextSpot *spot, PgfExn* err)=0;
 };
 
 PGF_INTERNAL_DECL
-void phrasetable_lookup(PgfPhrasetable table,
+void phrasetable_lookup(PgfPhrasetable<PgfSymbolKS> phrasetable,
                         PgfText *sentence,
                         bool case_sensitive,
                         PgfPhraseScanner *scanner, PgfExn* err);
 
 PGF_INTERNAL_DECL
-void phrasetable_lookup_cohorts(PgfPhrasetable table,
+void phrasetable_lookup_cohorts(PgfPhrasetable<PgfSymbolKS> phrasetable,
                                 PgfText *sentence,
                                 bool case_sensitive,
                                 PgfPhraseScanner *scanner, PgfExn* err);
 
+template <class V>
+void phrasetable_release(PgfPhrasetable<V> table)
+{
+    if (table == 0)
+        return;
+    phrasetable_release(table->left);
+    phrasetable_release(table->right);
+    for (size_t i = 0; i < table->value.n_items; i++) {
+        PgfItem::release(table->value.items[i]);
+    }
+    vector<ref<PgfItem>>::release(table->value.items);
+    Node<PgfPhrasetableValue<V>>::release(table);
+}
+
+
+typedef ref<Node<PgfCCat>> PgfEpsilontable;
+
+// Creates a new epsilon category with its first item.
+// The new category is mutable within the current transaction
 PGF_INTERNAL_DECL
-void phrasetable_iter(PgfConcr *concr,
+PgfEpsilontable epsilontable_insert(PgfEpsilontable table,
-                      PgfPhrasetable table,
+                                    ref<PgfConcrLincat> lincat, PgfMetaId prev_fid,
-                      PgfSequenceItor* itor,
+                                    interval_t value, interval_t lin_idx,
-                      PgfMorphoCallback *callback,
+                                    PgfMetaId fid, prob_t viterbi_prob,
-                      PgfPhrasetableIds *seq_ids, PgfExn *err);
+                                    ref<PgfItem> item,
+                                    ref<PgfCCat> *pepsilon);
+
+// Adds a new item to an existing epsilon category. The category
+// must have been created by epsilontable_insert in the current transaction.
+PGF_INTERNAL_DECL
+void epsilontable_add(ref<PgfCCat> epsilon, ref<PgfItem> item);
 
 PGF_INTERNAL_DECL
-void phrasetable_release(PgfPhrasetable table);
+ref<PgfCCat> epsilontable_get(PgfEpsilontable table,
+                              PgfText *name, PgfMetaId fid);
 
-// The following are used internally in the parser
+PGF_INTERNAL
-
+void epsilontable_iter(PgfEpsilontable table,
-enum SeqMatch { SM_FULL_MATCH, SM_PREFIX, SM_PARTIAL };
+                       ref<PgfConcrLincat> lincat, PgfMetaId prev_fid,
+                       std::function<void(ref<PgfCCat> arg)> &f);
 
 PGF_INTERNAL_DECL
-int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end,
+void epsilontable_release(PgfEpsilontable table);
-                      ref<PgfSequence> seq, size_t *p_i,
-                      bool case_sensitive, SeqMatch sm);
-
-// The following is used internally in the grammar builder
-
-PGF_INTERNAL_DECL
-void phrasetable_add_backref(ref<PgfPhrasetableEntry> entry, txn_t txn_id,
-                             object container,
-                             size_t seq_index);
 
 #endif

src/runtime/c/pgf/printer.cxx

@@ -499,15 +499,15 @@ void PgfPrinter::lparam(ref<PgfLParam> lparam)
     }
 }
 
-void PgfPrinter::lvar_ranges(vector<PgfVariableRange> vars, size_t *values)
+void PgfPrinter::lvar_ranges(vector<size_t> ranges, size_t *values)
 {
     puts("{");
-    for (size_t i = 0; i < vars.size(); i++) {
+    for (size_t i = 0; i < ranges.size(); i++) {
         if (i > 0)
             puts(", ");
-        lvar(vars[i].var);
+        lvar(i);
         if (values == NULL || values[i] == 0)
-            nprintf(32,"<%ld",vars[i].range);
+            nprintf(32,"<%ld",ranges[i]);
         else
             nprintf(32,"=%ld",values[i]-1);
     }
@@ -524,13 +524,6 @@ void PgfPrinter::symbol(PgfSymbol sym)
         puts(">");
 		break;
 	}
-	case PgfSymbolLit::tag: {
-        auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
-        nprintf(32, "{%ld,",sym_lit->d);
-        lparam(ref<PgfLParam>::from_ptr(&sym_lit->r));
-        puts("}");
-		break;
-	}
 	case PgfSymbolVar::tag: {
         auto sym_var = ref<PgfSymbolVar>::untagged(sym);
         nprintf(64, "<%ld,$%ld>",sym_var->d, sym_var->r);
@@ -545,11 +538,11 @@ void PgfPrinter::symbol(PgfSymbol sym)
         auto sym_kp = ref<PgfSymbolKP>::untagged(sym);
         puts("pre {");
 
-        sequence(sym_kp->default_form);
+        symbols(sym_kp->default_form);
 
         for (size_t i = 0; i < sym_kp->alts.size(); i++) {
             puts("; ");
-            sequence(sym_kp->alts[i].form);
+            symbols(sym_kp->alts[i].form);
             puts(" /");
             for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) {
                 puts(" ");
@@ -581,19 +574,86 @@ void PgfPrinter::symbol(PgfSymbol sym)
 	}
 }
 
-void PgfPrinter::sequence(ref<PgfSequence> seq)
+void PgfPrinter::symbols(vector<PgfSymbol> syms)
 {
-    for (size_t i = 0; i < seq->syms.size(); i++) {
+    for (size_t i = 0; i < syms.size(); i++) {
         if (i > 0)
             puts(" ");
 
-        symbol(seq->syms[i]);
+        symbol(syms[i]);
     }
 }
 
-void PgfPrinter::seq_id(PgfPhrasetableIds *seq_ids, ref<PgfSequence> seq)
+void PgfPrinter::item(ref<PgfItem> item)
 {
-	nprintf(5, "S%zu", seq_ids->get(seq));
+    switch (ref<PgfConcrLin>::get_tag(item->rule->container)) {
+    case PgfConcrLincat::tag: {
+        ref<PgfConcrLincat> lincat = ref<PgfConcrLincat>::untagged(item->rule->container);
+
+        if (item->rule->ranges != 0) {
+            lvar_ranges(item->rule->ranges, &item->vars[0]);
+            puts(" ");
+        }
+
+        puts("String(");
+        lparam(item->rule->res);
+        puts(") -> ");
+
+        efun(&lincat->name);
+        puts("[");
+        efun(&lincat->name);
+        puts("(");
+        lparam(item->rule->args[0]);
+        puts(")]; ");
+        break;
+    }
+    case PgfConcrLin::tag: {
+        ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(item->rule->container);
+        ref<PgfDTyp> ty = lin->absfun->type;
+
+        if (item->rule->ranges != 0) {
+            lvar_ranges(item->rule->ranges, &item->vars[0]);
+            puts(" ");
+        }
+
+        efun(&ty->name);
+        puts("(");
+        lparam(item->rule->res);
+        puts(") -> ");
+
+        efun(&lin->name);
+        puts("[");
+        for (size_t i = 0; i < item->rule->args.size(); i++) {
+            if (i > 0)
+                puts(",");
+            if (item->args[i] == 0) {
+                efun(&ty->hypos.elem(i)->type->name);
+                puts("(");
+                lparam(item->rule->args[i]);
+                puts(")");
+            } else {
+                emeta(0);
+            }
+        }
+        puts("]; ");
+        break;
+    }
+    }
+
+    lparam(item->rule->lin_idx);
+    puts(" : ");
+
+    for (size_t i = 0; i < item->rule->syms.size(); i++) {
+        if (i > 0)
+            puts(" ");
+
+        if (item->pre_alt == 0 && item->dot == i)
+            puts(". ");
+        else if (item->pre_alt > 0 && item->pre_dot == i)
+            puts(". ");
+
+        symbol(item->rule->syms[i]);
+    }
 }
 
 void PgfPrinter::free_ref(object x)

src/runtime/c/pgf/printer.h

@@ -78,10 +78,10 @@ public:
     void parg(ref<PgfDTyp> ty, ref<PgfPArg> parg);
     void lvar(size_t var);
     void lparam(ref<PgfLParam> lparam);
-    void lvar_ranges(vector<PgfVariableRange> vars, size_t *values);
+    void lvar_ranges(vector<size_t> ranges, size_t *values);
-    void seq_id(PgfPhrasetableIds *seq_ids, ref<PgfSequence> seq);
     void symbol(PgfSymbol sym);
-    void sequence(ref<PgfSequence> seq);
+    void symbols(vector<PgfSymbol> syms);
+    void item(ref<PgfItem> item);
 
     virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body);
     virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);

src/runtime/c/pgf/probspace.cxx

@@ -154,7 +154,9 @@ PgfProbspace probspace_delete_by_cat(PgfProbspace space, PgfText *cat,
 
         return Node<PgfProbspaceEntry>::link(space,space->left,right);
     } else {
-        itor->fn(itor, &space->value.fun->name, space->value.fun.as_object(), err);
+        PgfText *name = textdup(&space->value.fun->name);
+        itor->fn(itor, name, space->value.fun.as_object(), err);
+        free(name);
         if (err->type != PGF_EXN_NONE)
             return 0;
 

src/runtime/c/pgf/reader.cxx

@@ -10,6 +10,7 @@ PgfReader::PgfReader(FILE *in,PgfProbsCallback *probs_callback)
     this->probs_callback = probs_callback;
     this->abstract = 0;
     this->concrete = 0;
+    this->container = 0;
 }
 
 uint8_t PgfReader::read_uint8()
@@ -161,6 +162,21 @@ ref<C> PgfReader::read_vector(inline_vector<V> C::* field, void (PgfReader::*rea
     return loc;
 }
 
+template <class V>
+vector<V> PgfReader::read_null_vector(void (PgfReader::*read_value)(ref<V> val))
+{
+    size_t len = read_len();
+    if (len == 0) {
+        return 0;
+    } else {
+        vector<V> vec = vector<V>::alloc(len);
+        for (size_t i = 0; i < len; i++) {
+            (this->*read_value)(vec.elem(i));
+        }
+        return vec;
+    }
+}
+
 template <class V>
 vector<V> PgfReader::read_vector(void (PgfReader::*read_value)(ref<V> val))
 {
@@ -481,10 +497,9 @@ ref<PgfLParam> PgfReader::read_lparam()
     return lparam;
 }
 
-void PgfReader::read_variable_range(ref<PgfVariableRange> var_info)
+void PgfReader::read_variable_range(ref<size_t> var_range)
 {
-    var_info->var   = read_int();
+    *var_range = read_int();
-    var_info->range = read_int();
 }
 
 void PgfReader::read_parg(ref<PgfPArg> parg)
@@ -492,33 +507,6 @@ void PgfReader::read_parg(ref<PgfPArg> parg)
     auto param = read_lparam(); parg->param = param;
 }
 
-ref<PgfPResult> PgfReader::read_presult()
-{
-    vector<PgfVariableRange> vars = 0;
-    size_t n_vars = read_len();
-    if (n_vars > 0) {
-        vars = vector<PgfVariableRange>::alloc(n_vars);
-        for (size_t i = 0; i < n_vars; i++) {
-            read_variable_range(vars.elem(i));
-        }
-    }
-
-    size_t i0 = read_int();
-    size_t n_terms = read_len();
-    ref<PgfPResult> res =
-        PgfDB::malloc<PgfPResult>(n_terms*sizeof(PgfLParam::terms[0]));
-    res->vars = vars;
-    res->param.i0 = i0;
-    res->param.n_terms = n_terms;
-
-    for (size_t i = 0; i < n_terms; i++) {
-        res->param.terms[i].factor = read_int();
-        res->param.terms[i].var    = read_int();
-    }
-
-    return res;
-}
-
 template<class I>
 ref<I> PgfReader::read_symbol_idx()
 {
@@ -549,11 +537,6 @@ PgfSymbol PgfReader::read_symbol()
         ref<PgfSymbolCat> sym_cat = read_symbol_idx<PgfSymbolCat>();
         sym = sym_cat.tagged();
 		break;
-    }
-	case PgfSymbolLit::tag: {
-        ref<PgfSymbolLit> sym_lit = read_symbol_idx<PgfSymbolLit>();
-        sym = sym_lit.tagged();
-		break;
     }
 	case PgfSymbolVar::tag: {
         ref<PgfSymbolVar> sym_var = PgfDB::malloc<PgfSymbolVar>();
@@ -572,14 +555,14 @@ PgfSymbol PgfReader::read_symbol()
         ref<PgfSymbolKP> sym_kp = inline_vector<PgfAlternative>::alloc(&PgfSymbolKP::alts,n_alts);
 
         for (size_t i = 0; i < n_alts; i++) {
-            auto form     = read_seq();
+            auto form     = read_vector(&PgfReader::read_symbol2);
             auto prefixes = read_vector(&PgfReader::read_text2);
 
             sym_kp->alts[i].form     = form;
             sym_kp->alts[i].prefixes = prefixes;
         }
 
-        auto default_form = read_seq();
+        auto default_form = read_vector(&PgfReader::read_symbol2);
         sym_kp->default_form = default_form;
 
         sym = sym_kp.tagged();
@@ -616,80 +599,50 @@ PgfSymbol PgfReader::read_symbol()
     return sym;
 }
 
-ref<PgfSequence> PgfReader::read_seq()
+ref<PgfConcrRule> PgfReader::read_rule()
 {
-	size_t n_syms = read_len();
+    size_t n_syms = read_len();
+    ref<PgfConcrRule> rule = inline_vector<PgfSymbol>::alloc(&PgfConcrRule::syms, n_syms);
 
-	ref<PgfSequence> seq = inline_vector<PgfSymbol>::alloc(&PgfSequence::syms, n_syms);
+    vector<size_t> ranges = read_null_vector(&PgfReader::read_variable_range);
+    ref<PgfLParam> res = read_lparam();
+    vector<ref<PgfLParam>> args = read_null_vector(&PgfReader::read_lparam);
+    ref<PgfLParam> lin_idx = read_lparam();
+
+    rule->ranges = ranges;
+    rule->res  = res;
+    rule->container = container;
+    rule->args = args;
+    rule->lin_idx = lin_idx;
 
     for (size_t i = 0; i < n_syms; i++) {
         PgfSymbol sym = read_symbol();
-        seq->syms[i] = sym;
+        rule->syms[i] = sym;
     }
 
-    return seq;
+    return rule;
-}
-
-vector<ref<PgfSequence>> PgfReader::read_seq_ids(object container)
-{
-    size_t len = read_len();
-    vector<ref<PgfSequence>> vec = vector<ref<PgfSequence>>::alloc(len);
-    for (size_t i = 0; i < len; i++) {
-        size_t seq_id = read_len();
-        ref<PgfSequence> seq = phrasetable_relink(concrete->phrasetable,
-                                                  container, i,
-                                                  seq_id);
-        if (seq == 0) {
-            throw pgf_error("Invalid sequence id");
-        }
-        vec[i] = seq;
-    }
-    return vec;
-}
-
-PgfPhrasetable PgfReader::read_phrasetable(size_t len)
-{
-    if (len == 0)
-        return 0;
-
-    PgfPhrasetableEntry value;
-
-    size_t half = len/2;
-    PgfPhrasetable left  = read_phrasetable(half);
-    value.seq = read_seq();
-    value.n_backrefs = 0;
-    value.backrefs = 0;
-    PgfPhrasetable right = read_phrasetable(len-half-1);
-
-    PgfPhrasetable table = Node<PgfPhrasetableEntry>::new_node(value);
-    table->sz    = 1+Node<PgfPhrasetableEntry>::size(left)+Node<PgfPhrasetableEntry>::size(right);
-    table->left  = left;
-    table->right = right;
-    return table;
-}
-
-PgfPhrasetable PgfReader::read_phrasetable()
-{
-    size_t len = read_len();
-    return read_phrasetable(len);
 }
 
 ref<PgfConcrLincat> PgfReader::read_lincat()
 {
     ref<PgfConcrLincat> lincat = read_name(&PgfConcrLincat::name);
 
+    container = lincat.tagged();
+
     auto fields = read_lincat_fields(lincat);
     auto n_lindefs = read_len();
-    auto args = read_vector(&PgfReader::read_parg);
+    auto rules = read_vector(&PgfReader::read_rule2);
-    auto res  = read_vector(&PgfReader::read_presult2);
+
-    auto seqs = read_seq_ids(lincat.tagged());
+    container = 0;
+
+    for (size_t i = n_lindefs; i < rules.size(); i++) {
+        table_maker->insert_rule(rules[i]);
+    }
 
     lincat->abscat = namespace_lookup(abstract->cats, &lincat->name);
     lincat->fields = fields;
     lincat->n_lindefs = n_lindefs;
-    lincat->args = args;
+    lincat->rules = rules;
-    lincat->res  = res;
-    lincat->seqs = seqs;
     return lincat;
 }
 
@@ -715,13 +668,16 @@ ref<PgfConcrLin> PgfReader::read_lin()
     if (lin->lincat == 0)
         throw pgf_error("Found a lin which uses a category without a lincat");
 
-    auto args = read_vector(&PgfReader::read_parg);
+    container  = lin.tagged();
-    auto res  = read_vector(&PgfReader::read_presult2);
-    auto seqs = read_seq_ids(lin.tagged());
 
-    lin->args = args;
+    auto rules = read_vector(&PgfReader::read_rule2);
-    lin->res  = res;
+    lin->rules = rules;
-    lin->seqs = seqs;
+
+    container  = 0;
+
+    for (size_t i = 0; i < rules.size(); i++) {
+        table_maker->insert_rule(rules[i]);
+    }
 
     return lin;
 }
@@ -736,12 +692,18 @@ ref<PgfConcrPrintname> PgfReader::read_printname()
 ref<PgfConcr> PgfReader::read_concrete()
 {
     concrete = read_name(&PgfConcr::name);
+    concrete->phrasetable1 = 0;
+    concrete->phrasetable2 = 0;
+    concrete->phrasetable3 = 0;
+    concrete->phrasetable4 = 0;
+    concrete->epsilontable = 0;
+    concrete->last_fid = 0;
 
 	auto cflags = read_namespace<PgfFlag>(&PgfReader::read_flag);
 	concrete->cflags = cflags;
 
-	auto phrasetable = read_phrasetable();
+    PgfParseTableMaker tm(concrete);
-	concrete->phrasetable = phrasetable;
+    this->table_maker = &tm;
 
 	auto lincats = read_namespace<PgfConcrLincat>(&PgfReader::read_lincat);
 	concrete->lincats = lincats;
@@ -749,12 +711,14 @@ ref<PgfConcr> PgfReader::read_concrete()
 	auto lins = read_namespace<PgfConcrLin>(&PgfReader::read_lin);
 	concrete->lins = lins;
 
+    tm.prepare();
+
+    concrete->last_fid = tm.get_last_fid();
+    this->table_maker = NULL;
+
 	auto printnames = read_namespace<PgfConcrPrintname>(&PgfReader::read_printname);
 	concrete->printnames = printnames;
 
-    //PgfLRTableMaker maker(abstract, concrete);
-    //concrete->lrtable = maker.make();
-
     return concrete;
 }
 

src/runtime/c/pgf/reader.h

@@ -51,6 +51,9 @@ public:
     template <class C, class V>
     ref<C> read_vector(inline_vector<V> C::* field, void (PgfReader::*read_value)(ref<V> val));
 
+    template<class V>
+    vector<V> read_null_vector(void (PgfReader::*read_value)(ref<V> val));
+
     template<class V>
     vector<V> read_vector(void (PgfReader::*read_value)(ref<V> val));
 
@@ -70,17 +73,13 @@ public:
     void read_abstract(ref<PgfAbstr> abstract);
     void merge_abstract(ref<PgfAbstr> abstract);
 
+    ref<PgfConcrRule> read_rule();
     ref<PgfConcrLincat> read_lincat();
     vector<ref<PgfText>> read_lincat_fields(ref<PgfConcrLincat> lincat);
     ref<PgfLParam> read_lparam();
-    void read_variable_range(ref<PgfVariableRange> var_info);
+    void read_variable_range(ref<size_t> var_range);
     void read_parg(ref<PgfPArg> parg);
-    ref<PgfPResult> read_presult();
     PgfSymbol read_symbol();
-    ref<PgfSequence> read_seq();
-    vector<ref<PgfSequence>> read_seq_ids(object container);
-    PgfPhrasetable read_phrasetable(size_t len);
-    PgfPhrasetable read_phrasetable();
     ref<PgfConcrLin> read_lin();
     ref<PgfConcrPrintname> read_printname();
 
@@ -94,13 +93,17 @@ private:
     PgfProbsCallback *probs_callback;
     ref<PgfAbstr> abstract;
     ref<PgfConcr> concrete;
+    object container;
+
+    class PgfParseTableMaker *table_maker;
 
     object read_name_internal(size_t struct_size);
     object read_text_internal(size_t struct_size);
 
     void read_text2(ref<ref<PgfText>> r) { auto text = read_text(); *r = text; }
     void read_lparam(ref<ref<PgfLParam>> r) { auto lparam = read_lparam(); *r = lparam; }
-    void read_presult2(ref<ref<PgfPResult>> r) { auto res = read_presult(); *r = res; }
+    void read_rule2(ref<ref<PgfConcrRule>> r) { auto rule = read_rule(); *r = rule; }
+    void read_symbol2(ref<PgfSymbol> r) { auto sym = read_symbol(); *r = sym; }
 
     template<class I>
     ref<I> read_symbol_idx();

src/runtime/c/pgf/typechecker.cxx

@@ -82,7 +82,7 @@ PgfType PgfTypechecker::marshall_type(Type *ty, PgfUnmarshaller *u)
     for (;;) {
         Pi *pi = ty->is_pi();
         if (pi) {
-            hypos = (PgfTypeHypo *) realloc(hypos, n_hypos*sizeof(PgfTypeHypo));
+            hypos = (PgfTypeHypo *) realloc(hypos, (n_hypos+1)*sizeof(PgfTypeHypo));
             PgfTypeHypo *hypo = &hypos[n_hypos++];
             hypo->bind_type = pi->bind_type;
             hypo->cid = &pi->var;

src/runtime/c/pgf/writer.cxx

@@ -144,6 +144,19 @@ void PgfWriter::write_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V
     }
 }
 
+template<class V>
+void PgfWriter::write_null_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val))
+{
+    if (vec == 0) {
+        write_len(0);
+    } else {
+        write_len(vec.size());
+        for (size_t i = 0; i < vec.size(); i++) {
+            (this->*write_value)(vec.elem(i));
+        }
+    }
+}
+
 void PgfWriter::write_literal(PgfLiteral literal)
 {
     auto tag = ref<PgfLiteral>::get_tag(literal);
@@ -277,10 +290,9 @@ void PgfWriter::write_abstract(ref<PgfAbstr> abstract)
     this->abstract = 0;
 }
 
-void PgfWriter::write_variable_range(ref<PgfVariableRange> var)
+void PgfWriter::write_variable_range(ref<size_t> var_range)
 {
-    write_int(var->var);
+    write_int(*var_range);
-    write_int(var->range);
 }
 
 void PgfWriter::write_lparam(ref<PgfLParam> lparam)
@@ -293,18 +305,19 @@ void PgfWriter::write_lparam(ref<PgfLParam> lparam)
     }
 }
 
-void PgfWriter::write_parg(ref<PgfPArg> parg)
+void PgfWriter::write_rule(ref<PgfConcrRule> rule)
 {
-    write_lparam(parg->param);
+    write_len(rule->syms.size());
-}
 
-void PgfWriter::write_presult(ref<PgfPResult> pres)
+    write_null_vector(rule->ranges, &PgfWriter::write_variable_range);
-{
+    write_lparam(rule->res);
-    if (pres->vars != 0)
+    write_null_vector(rule->args, &PgfWriter::write_lparam);
-        write_vector(pres->vars, &PgfWriter::write_variable_range);
+
-    else
+    write_lparam(rule->lin_idx);
-        write_len(0);
+
-    write_lparam(ref<PgfLParam>::from_ptr(&pres->param));
+    for (PgfSymbol sym : rule->syms) {
+        write_symbol(sym);
+    }
 }
 
 void PgfWriter::write_symbol(PgfSymbol sym)
@@ -319,12 +332,6 @@ void PgfWriter::write_symbol(PgfSymbol sym)
         write_lparam(ref<PgfLParam>::from_ptr(&sym_cat->r));
 		break;
 	}
-	case PgfSymbolLit::tag: {
-        auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
-        write_int(sym_lit->d);
-        write_lparam(ref<PgfLParam>::from_ptr(&sym_lit->r));
-		break;
-	}
 	case PgfSymbolVar::tag: {
         auto sym_var = ref<PgfSymbolVar>::untagged(sym);
         write_int(sym_var->d);
@@ -341,10 +348,10 @@ void PgfWriter::write_symbol(PgfSymbol sym)
         write_len(sym_kp->alts.size());
         for (size_t i = 0; i < sym_kp->alts.size(); i++) {
 			ref<PgfAlternative> alt = sym_kp->alts.elem(i);
-            write_vector(alt->form->syms.as_vector(), &PgfWriter::write_symbol);
+            write_vector(alt->form, &PgfWriter::write_symbol);
             write_vector(alt->prefixes, &PgfWriter::write_text);
         }
-        write_vector(sym_kp->default_form->syms.as_vector(), &PgfWriter::write_symbol);
+        write_vector(sym_kp->default_form, &PgfWriter::write_symbol);
 		break;
 	}
 	case PgfSymbolBIND::tag:
@@ -359,36 +366,12 @@ void PgfWriter::write_symbol(PgfSymbol sym)
 	}
 }
 
-void PgfWriter::write_seq(ref<PgfSequence> seq)
-{
-	seq_ids.add(seq);
-    write_vector(seq->syms.as_vector(), &PgfWriter::write_symbol);
-}
-
-void PgfWriter::write_phrasetable(PgfPhrasetable table)
-{
-    write_len(phrasetable_size(table));
-    write_phrasetable_helper(table);
-}
-
-void PgfWriter::write_phrasetable_helper(PgfPhrasetable table)
-{
-    if (table == 0)
-        return;
-
-    write_phrasetable_helper(table->left);
-    write_seq(table->value.seq);
-    write_phrasetable_helper(table->right);
-}
-
 void PgfWriter::write_lincat(ref<PgfConcrLincat> lincat)
 {
     write_name(&lincat->name);
     write_vector(lincat->fields, &PgfWriter::write_lincat_field);
     write_len(lincat->n_lindefs);
-    write_vector(lincat->args, &PgfWriter::write_parg);
+    write_vector(lincat->rules, &PgfWriter::write_rule);
-    write_vector(lincat->res, &PgfWriter::write_presult);
-    write_vector(lincat->seqs, &PgfWriter::write_seq_id);
 }
 
 void PgfWriter::write_lincat_field(ref<ref<PgfText>> field)
@@ -399,9 +382,7 @@ void PgfWriter::write_lincat_field(ref<ref<PgfText>> field)
 void PgfWriter::write_lin(ref<PgfConcrLin> lin)
 {
     write_name(&lin->name);
-    write_vector(lin->args, &PgfWriter::write_parg);
+    write_vector(lin->rules, &PgfWriter::write_rule);
-    write_vector(lin->res, &PgfWriter::write_presult);
-    write_vector(lin->seqs, &PgfWriter::write_seq_id);
 }
 
 void PgfWriter::write_printname(ref<PgfConcrPrintname> printname)
@@ -428,16 +409,11 @@ void PgfWriter::write_concrete(ref<PgfConcr> concr)
         }
     }
 
-	seq_ids.start(concr);
-
     write_name(&concr->name);
     write_namespace<PgfFlag>(concr->cflags, &PgfWriter::write_flag);
-	write_phrasetable(concr->phrasetable);
     write_namespace<PgfConcrLincat>(concr->lincats, &PgfWriter::write_lincat);
 	write_namespace<PgfConcrLin>(concr->lins, &PgfWriter::write_lin);
 	write_namespace<PgfConcrPrintname>(concr->printnames, &PgfWriter::write_printname);
-
-	seq_ids.end();
 }
 
 void PgfWriter::write_pgf(ref<PgfPGF> pgf)

src/runtime/c/pgf/writer.h

@@ -24,6 +24,8 @@ public:
 
     template<class V>
     void write_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val));
+    template<class V>
+    void write_null_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val));
 
     void write_literal(PgfLiteral literal);
     void write_expr(PgfExpr expr);
@@ -40,14 +42,9 @@ public:
 
     void write_lincat(ref<PgfConcrLincat> lincat);
     void write_lincat_field(ref<ref<PgfText>> field);
-    void write_variable_range(ref<PgfVariableRange> var);
+    void write_variable_range(ref<size_t> var_range);
     void write_lparam(ref<PgfLParam> lparam);
-    void write_parg(ref<PgfPArg> linarg);
-    void write_presult(ref<PgfPResult> linres);
     void write_symbol(PgfSymbol sym);
-    void write_seq(ref<PgfSequence> seq);
-    void write_seq_id(ref<ref<PgfSequence>> r) { write_len(seq_ids.get(*r)); };
-    void write_phrasetable(PgfPhrasetable table);
     void write_lin(ref<PgfConcrLin> lin);
     void write_printname(ref<PgfConcrPrintname> printname);
 
@@ -58,18 +55,17 @@ public:
 private:
     template<class V>
     void write_namespace_helper(Namespace<V> nmsp, void (PgfWriter::*write_value)(ref<V>));
-    void write_phrasetable_helper(PgfPhrasetable table);
 
     void write_text(ref<ref<PgfText>> r) { write_text(&(**r)); };
     void write_lparam(ref<ref<PgfLParam>> r) { write_lparam(*r); };
+    void write_rule(ref<PgfConcrRule> rule);
     void write_symbol(ref<PgfSymbol> r) { write_symbol(*r); };
-    void write_presult(ref<ref<PgfPResult>> r) { write_presult(*r); };
+    void write_rule(ref<ref<PgfConcrRule>> r) { write_rule(*r); };
 
     FILE *out;
     PgfText **langs;
 
     ref<PgfAbstr> abstract;
-    PgfPhrasetableIds seq_ids;
 };
 
 #endif

src/runtime/haskell/PGF.hs

@@ -0,0 +1,686 @@
+{-# LANGUAGE BangPatterns #-}
+-------------------------------------------------
+-- |
+-- Module      : PGF
+-- Maintainer  : Krasimir Angelov
+-- Stability   : stable
+-- Portability : portable
+--
+-- This module is an Application Programming Interface to
+-- load and interpret grammars compiled in Portable Grammar Format (PGF).
+-- The PGF format is produced as a final output from the GF compiler.
+-- The API is meant to be used for embedding GF grammars in Haskell
+-- programs
+-------------------------------------------------
+
+module PGF(
+           -- * PGF
+           PGF,
+           readPGF,
+
+           -- * Identifiers
+           CId, mkCId, wildCId,
+           showCId, readCId,
+           -- extra
+           ppCId, PGF2.pIdent,
+
+           -- * Languages
+           Language, 
+           showLanguage, readLanguage,
+           languages, abstractName, languageCode,
+
+           -- * Types
+           Type, Hypo, BindType(..),
+           PGF2.showType, PGF2.readType,
+           mkType, PGF2.mkHypo, mkDepHypo, mkImplHypo,
+           unType,
+           categories, categoryContext, PGF2.startCat,
+
+           -- * Functions
+           functions, functionsByCat, functionType, missingLins,
+
+           -- * Expressions & Trees
+           -- ** Tree
+           Tree,
+
+           -- ** Expr
+           Expr,
+           PGF2.showExpr, PGF2.readExpr, PGF2.pExpr,
+           mkAbs,         unAbs,
+           mkApp,         unApp, PGF2.unapply,
+           PGF2.mkStr,    PGF2.unStr,
+           PGF2.mkInt,    PGF2.unInt,
+           PGF2.mkDouble, PGF2.unDouble,
+           PGF2.mkFloat,  PGF2.unFloat,
+           PGF2.mkMeta,   PGF2.unMeta,
+           -- extra
+           PGF2.exprSize, PGF2.exprFunctions,
+
+           -- * Operations
+           -- ** Linearization
+           linearize, linearizeAllLang, linearizeAll, bracketedLinearize, {-bracketedLinearizeAll,-} tabularLinearizes,
+           showPrintName,
+
+           BracketedString(..), FId, LIndex, Token,
+           showBracketedString,flattenBracketedString,
+
+           -- ** Parsing
+           parse, parseAllLang, parseAll, complete,
+           ParseOutput(..), parse_,
+
+           -- ** Evaluation
+           {- PGF.compute, paraphrase,-}
+
+           -- ** Type Checking
+           -- | The type checker in PGF does both type checking and renaming
+           -- i.e. it verifies that all identifiers are declared and it
+           -- distinguishes between global function or type indentifiers and
+           -- variable names. The type checker should always be applied on
+           -- expressions entered by the user i.e. those produced via functions
+           -- like 'readType' and 'readExpr' because otherwise unexpected results
+           -- could appear. All typechecking functions returns updated versions
+           -- of the input types or expressions because the typechecking could
+           -- also lead to metavariables instantiations.
+           PGF2.checkType, PGF2.checkExpr, PGF2.inferExpr,
+
+           -- ** Generation
+           -- | The PGF interpreter allows automatic generation of
+           -- abstract syntax expressions of a given type. Since the
+           -- type system of GF allows dependent types, the generation
+           -- is in general undecidable. In fact, the set of all type
+           -- signatures in the grammar is equivalent to a Turing-complete language (Prolog).
+           --
+           -- There are several generation methods which mainly differ in:
+           --
+           --     * whether the expressions are sequentially or randomly generated?
+           --
+           --     * are they generated from a template? The template is an expression
+           --     containing meta variables which the generator will fill in.
+           --
+           --     * is there a limit of the depth of the expression?
+           --     The depth can be used to limit the search space, which 
+           --     in some cases is the only way to make the search decidable.
+           generateAll,         generateAllDepth,
+           {-generateFrom,        generateFromDepth,-}
+           generateRandom,      generateRandomDepth,
+           {-generateRandomFrom,  generateRandomFromDepth,-}
+
+           -- ** Morphological Analysis
+           Lemma, Analysis, Morpho,
+           lookupMorpho, buildMorpho, morphoMissing, morphoKnown,
+           fullFormLexicon,
+
+           -- ** Visualizations
+           graphvizAbstractTree,
+           graphvizParseTree,
+           graphvizParseTreeDep,
+           graphvizDependencyTree,
+           graphvizBracketedString,
+           graphvizAlignment,
+           gizaAlignment,
+           GraphvizOptions(..),
+           PGF2.graphvizDefaults,
+           -- extra:
+           Labels, getDepLabels,
+           CncLabels, getCncDepLabels,
+
+          ) where
+
+import Prelude hiding ((<>))
+import PGF2 (PGF, GraphvizOptions(..), FId, Expr(..), Type(..), Hypo, BindType(..), ParseOutput(..))
+import qualified PGF2
+import qualified Data.Map as Map
+import Control.Monad
+import Data.Char
+import Data.Maybe (fromMaybe)
+import Data.List (nub,intersperse,groupBy,sortBy,partition)
+import Data.Ord (comparing)
+import qualified Text.ParserCombinators.ReadP as RP
+import Text.PrettyPrint
+import System.Random
+
+---------------------------------------------------
+-- Interface
+---------------------------------------------------
+
+newtype CId = CId String deriving (Eq,Ord)
+
+mkCId = CId
+wildCId = CId "_"
+
+-- | Reads an identifier from 'String'. The function returns 'Nothing' if the string is not valid identifier.
+readCId :: String -> Maybe CId
+readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of
+              [x] -> Just x
+              _   -> Nothing
+
+-- | Renders the identifier as 'String'
+showCId :: CId -> String
+showCId (CId raw) = PGF2.showIdent raw
+
+instance Show CId where
+    showsPrec _ = showString . showCId
+
+instance Read CId where
+    readsPrec _ = RP.readP_to_S pCId
+
+pCId :: RP.ReadP CId
+pCId = do s <- PGF2.pIdent
+          if s == "_"
+            then RP.pfail
+            else return (mkCId s)
+
+ppCId :: CId -> Doc
+ppCId = text . showCId
+
+type Language = CId
+
+readLanguage = readCId
+showLanguage (CId lang) = lang
+
+-- | creates a type from list of hypothesises, category and
+-- list of arguments for the category. The operation
+-- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create
+-- @h_1 -> ... -> h_n -> C e_1 ... e_m@
+mkType :: [Hypo] -> CId -> [Expr] -> Type
+mkType hyps (CId cat) args = PGF2.mkType hyps cat args
+
+-- | creates hypothesis for dependent type i.e. (x : A)
+mkDepHypo :: CId -> Type -> Hypo
+mkDepHypo (CId x) ty = PGF2.mkDepHypo x ty
+
+-- | creates hypothesis for dependent type with implicit argument i.e. ({x} : A)
+mkImplHypo :: CId -> Type -> Hypo
+mkImplHypo (CId x) ty = PGF2.mkImplHypo x ty
+
+unType :: Type -> ([Hypo], CId, [Expr])
+unType (DTyp hyps cat es) = (hyps, CId cat, es)
+
+type Tree = Expr
+
+mkAbs :: BindType -> CId -> Expr -> Expr
+mkAbs bt (CId var) e = PGF2.mkAbs bt var e
+
+unAbs :: Expr -> Maybe (BindType, CId, Expr)
+unAbs e =
+  case PGF2.unAbs e of
+    Just (bt,var,e) -> Just (bt,CId var,e)
+    Nothing         -> Nothing
+
+mkApp :: CId -> [Expr] -> Expr
+mkApp (CId fun) es = PGF2.mkApp fun es
+
+unApp :: Expr -> Maybe (CId, [Expr])
+unApp e =
+  case PGF2.unApp e of
+    Just (fun,es) -> Just (CId fun,es)
+    Nothing       -> Nothing
+
+-- | Reads file in Portable Grammar Format and produces
+-- 'PGF' structure. The file is usually produced with:
+--
+-- > $ gf -make <grammar file name>
+readPGF  :: FilePath -> IO PGF
+readPGF = PGF2.readPGF
+
+-- | Tries to parse the given string in the specified language
+-- and to produce abstract syntax expression.
+parse :: PGF -> Language -> Type -> String -> [Tree]
+parse gr (CId lang) cat sent = 
+  case Map.lookup lang (PGF2.languages gr) of
+    Just cnc -> case PGF2.parse cnc cat sent of
+                  ParseOk ts -> map fst ts
+                  _          -> []
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+-- | The same as 'parseAllLang' but does not return
+-- the language.
+parseAll     :: PGF -> Type -> String -> [[Tree]]
+parseAll gr cat sent = 
+  [map fst ts | (lang,cnc) <- Map.toList (PGF2.languages gr)
+              , ParseOk ts <- [PGF2.parse cnc cat sent]]
+
+-- | Tries to parse the given string with all available languages.
+-- The returned list contains pairs of language
+-- and list of abstract syntax expressions 
+-- (this is a list, since grammars can be ambiguous). 
+-- Only those languages
+-- for which at least one parsing is possible are listed.
+parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
+parseAllLang gr cat sent = 
+  [(CId lang,map fst ts)
+              | (lang,cnc) <- Map.toList (PGF2.languages gr)
+              , ParseOk ts <- [PGF2.parse cnc cat sent]]
+
+-- | The same as 'parse' but returns more detailed information
+parse_ :: PGF -> Language -> Type -> Maybe Int -> String -> (ParseOutput [Expr],BracketedString)
+parse_ gr (CId lang) cat dp sent =
+  case Map.lookup lang (PGF2.languages gr) of
+    Just cnc -> case (PGF2.parse cnc cat sent,dp) of
+                  (ParseOk ts,     Just n) -> (ParseOk (map fst (take n ts)),noBS)
+                  (ParseOk ts,    Nothing) -> (ParseOk (map fst ts),noBS)
+                  (ParseFailed pos,_     ) -> (ParseFailed pos,noBS)
+                  (ParseIncomplete,_     ) -> (ParseIncomplete,noBS)
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+complete :: PGF -> Language -> Type -> String -> String -> (BracketedString,String,Map.Map Token [CId])
+complete pgf (CId lang) typ input prefix =
+  case Map.lookup lang (PGF2.languages pgf) of
+    Just cnc -> case PGF2.complete cnc typ input prefix of
+                  ParseOk res -> (noBS, input++" "++prefix, Map.fromListWith (++) [(w,[CId fun]) | (w,fun,cat,_) <- res])
+                  _           -> (noBS, input++" "++prefix, Map.empty)
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+noBS = error "TODO: The bracketed string is not computed"
+
+linearize :: PGF -> Language -> Tree -> String
+linearize pgf (CId lang) t =
+  case Map.lookup lang (PGF2.languages pgf) of
+    Just cnc -> PGF2.linearize cnc t
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+-- | The same as 'linearizeAllLang' but does not return
+-- the language.
+linearizeAll :: PGF -> Tree -> [String]
+linearizeAll pgf = map snd . linearizeAllLang pgf
+
+-- | Linearizes given expression as string in all languages
+-- available in the grammar.
+linearizeAllLang :: PGF -> Tree -> [(Language,String)]
+linearizeAllLang pgf t = [(CId lang,PGF2.linearize cnc t) | (lang,cnc) <- Map.toList (PGF2.languages pgf)]
+
+-- | Linearizes given expression as a bracketed string in the language
+bracketedLinearize :: PGF -> Language -> Tree -> [BracketedString]
+bracketedLinearize pgf (CId lang) t =
+  case Map.lookup lang (PGF2.languages pgf) of
+    Just cnc -> map bs2bs (PGF2.bracketedLinearize cnc t)
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+-- | Creates a table from feature name to linearization. 
+-- The outher list encodes the variations
+tabularLinearizes :: PGF -> Language -> Expr -> [[(String,String)]]
+tabularLinearizes pgf (CId lang) t =
+  case Map.lookup lang (PGF2.languages pgf) of
+    Just cnc -> [PGF2.tabularLinearize cnc t]
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+showPrintName :: PGF -> Language -> CId -> String
+showPrintName gr (CId lang) (CId name) =
+  case Map.lookup lang (PGF2.languages gr) of
+    Just cnc -> fromMaybe name (PGF2.printName cnc name)
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+-- | List of all languages available in the given grammar.
+languages    :: PGF -> [Language]
+languages gr = [CId lang | (lang,_) <- Map.toList (PGF2.languages gr)]
+
+-- | Gets the RFC 4646 language tag 
+-- of the language which the given concrete syntax implements,
+-- if this is listed in the source grammar.
+-- Example language tags include @\"en\"@ for English,
+-- and @\"en-UK\"@ for British English.
+languageCode :: PGF -> Language -> Maybe String
+languageCode gr (CId lang) =
+  case Map.lookup lang (PGF2.languages gr) of
+    Just cnc -> PGF2.languageCode cnc
+    _        -> Nothing
+
+-- | The abstract language name is the name of the top-level
+-- abstract module
+abstractName :: PGF -> Language
+abstractName gr = CId (PGF2.abstractName gr)
+
+-- | List of all categories defined in the given grammar.
+-- The categories are defined in the abstract syntax
+-- with the \'cat\' keyword.
+categories :: PGF -> [CId]
+categories gr = map CId (PGF2.categories gr)
+
+categoryContext :: PGF -> CId -> Maybe [Hypo]
+categoryContext gr (CId cat) = PGF2.categoryContext gr cat
+
+-- | List of all functions defined in the abstract syntax
+functions :: PGF -> [CId]
+functions gr = map CId (PGF2.functions gr)
+
+-- | List of all functions defined for a given category
+functionsByCat :: PGF -> CId -> [CId]
+functionsByCat gr (CId fun) = map CId (PGF2.functionsByCat gr fun)
+
+-- | The type of a given function
+functionType :: PGF -> CId -> Maybe Type
+functionType gr (CId fun) = PGF2.functionType gr fun
+
+-- | List of functions that lack linearizations in the given language.
+missingLins :: PGF -> Language -> [CId]
+missingLins gr (CId lang) =
+  case Map.lookup lang (PGF2.languages gr) of
+    Just cnc -> [CId c | c <- PGF2.functions gr, PGF2.hasLinearization cnc c]
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+
+type LIndex= String
+type Token = String
+
+-- | BracketedString represents a sentence that is linearized
+-- as usual but we also want to retain the ''brackets'' that
+-- mark the beginning and the end of each constituent.
+data BracketedString
+  = Leaf Token                                                                -- ^ this is the leaf i.e. a single token
+  | Bracket CId {-# UNPACK #-} !FId {-# UNPACK #-} !FId LIndex CId [Expr] [BracketedString]
+                                                                               -- ^ this is a bracket. The 'CId' is the category of
+                                                                               -- the phrase. The 'FId' is an unique identifier for
+                                                                               -- every phrase in the sentence. For context-free grammars
+                                                                               -- i.e. without discontinuous constituents this identifier
+                                                                               -- is also unique for every bracket. When there are discontinuous 
+                                                                               -- phrases then the identifiers are unique for every phrase but
+                                                                               -- not for every bracket since the bracket represents a constituent.
+                                                                               -- The different constituents could still be distinguished by using
+                                                                               -- the constituent index i.e. 'LIndex'. If the grammar is reduplicating
+                                                                               -- then the constituent indices will be the same for all brackets
+                                                                               -- that represents the same constituent.
+
+bs2bs (PGF2.Leaf token) = Leaf token
+bs2bs PGF2.BIND         = Leaf "&+"
+bs2bs (PGF2.Bracket cat fid lbl fun bs) = Bracket (CId cat) fid fid lbl (CId fun) [] (map bs2bs bs)
+
+-- | Renders the bracketed string as string where 
+-- the brackets are shown as @(S ...)@ where
+-- @S@ is the category.
+showBracketedString :: BracketedString -> String
+showBracketedString = render . ppBracketedString
+
+ppBracketedString (Leaf t) = text t
+ppBracketedString (Bracket cat fid fid' index _ _ bss) = parens (ppCId cat <> colon <> int fid <+> hsep (map ppBracketedString bss))
+
+flattenBracketedString :: BracketedString -> [String]
+flattenBracketedString (Leaf w)                  = [w]
+flattenBracketedString (Bracket _ _ _ _ _ _ bss) = concatMap flattenBracketedString bss  
+
+-- | Renders abstract syntax tree in Graphviz format.
+-- The pair of 'Bool' @(funs,cats)@ lets you control whether function names and
+-- category names are included in the rendered tree
+graphvizAbstractTree :: PGF -> (Bool,Bool) -> Tree -> String
+graphvizAbstractTree gr (funs,cats) = PGF2.graphvizAbstractTree gr PGF2.graphvizDefaults{noFun=not funs,noCat=not cats}
+
+graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
+graphvizParseTree gr (CId lang) opts t =
+   case Map.lookup lang (PGF2.languages gr) of
+    Just cnc -> PGF2.graphvizParseTree cnc opts t
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+type Labels = Map.Map CId [String]
+type CncLabels = [CncLabel]
+
+data CncLabel =
+    CncSyncat (String, String -> Maybe (String -> String,String,String))
+    -- (fun, word/lemma -> (pos,label,target))
+    -- the pos can remain unchanged, as in the current notation in the article
+  | CncMorpho (String,[String])
+    -- (category, features in ascending order)
+  | CncForm (String,(String,String))
+    -- (wordform, (lemma,features))
+
+-- | Prepare lines obtained from a configuration file for labels for
+-- use with 'graphvizDependencyTree'. Format per line /fun/ /label/@*@.
+--- ignore other gf-ud annotatations than #fun and #cat at this point 
+getDepLabels :: String -> Labels
+getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map (words . rmcomments) (lines s), not (head f == '#')]
+
+getCncDepLabels :: String -> CncLabels
+getCncDepLabels s = wlabels ws ++ flabels fs
+ where
+  wlabels =
+    map CncSyncat .
+    map merge .
+    groupBy (\ (x,_) (a,_) -> x == a) .
+    sortBy (comparing fst) .
+    concatMap analyse .
+    filter chooseW
+    
+  flabels =
+    map CncMorpho .
+    map collectTags .
+    map words
+
+  (fs,ws) = partition chooseF $ map uncomment $ lines s
+
+  --- choose is for compatibility with the general notation
+  chooseW line = notElem '(' line &&
+                 elem '{' line
+                   --- ignoring non-local (with "(") and abstract (without "{") rules
+                   ---- TODO: this means that "(" cannot be a token
+
+  chooseF line = take 1 line == "@"  --- feature assignments have the form e.g. @N SgNom SgGen ; no spaces inside tags
+
+  uncomment line = case line of
+    '-':'-':_ -> ""
+    c:cs -> c : uncomment cs
+    _ -> line
+
+  analyse line = case break (=='{') line of
+    (beg,_:ws) -> case break (=='}') ws of
+      (toks,_:target) -> case (getToks beg, words target) of
+        (funs,[    label,j]) -> [(fun, (tok, (id,       label,j))) | fun <- funs, tok <- getToks toks]
+        (funs,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | fun <- funs, tok <- getToks toks]
+        _ -> []
+      _ -> []
+    _ -> []
+  merge rules@((fun,_):_) = (fun, \tok ->
+    case lookup tok (map snd rules) of
+      Just new -> return new
+      _ -> lookup "*"  (map snd rules)
+    )
+  getToks = map unquote . filter (/=",") . toks
+  toks s = case lex s of [(t,"")] -> [t] ; [(t,cc)] -> t:toks cc ; _ -> []
+  unquote s = case s of '"':cc@(_:_) | last cc == '"' -> init cc ; _ -> s
+
+  collectTags (w:ws) = (tail w,ws)
+
+-- auxiliaries for UD conversion  PK 15/12/2018 
+rmcomments :: String -> String
+rmcomments s = case s of
+  '-':'-':_ -> []
+  '#':'f':'u':'n':rest -> rmcomments rest -- the new gf-ud format
+  '#':'c':'a':'t':rest -> rmcomments rest
+  x:xs -> x : rmcomments xs
+  _ -> []
+
+-- | Visualize word dependency tree.
+graphvizDependencyTree
+  :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@
+  -> Bool -- ^ Include extra information (debug)
+  -> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels'
+  -> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@))
+  -> PGF
+  -> CId -- ^ The language of analysis
+  -> Tree
+  -> String -- ^ Rendered output in the specified format
+graphvizDependencyTree format debug mb_labels mb_cnclabels gr (CId lang) t =
+  error "TODO: graphvizDependencyTree"
+
+graphvizParseTreeDep :: Maybe Labels -> PGF -> Language -> GraphvizOptions -> Tree -> String
+graphvizParseTreeDep mbl pgf lang opts tree = graphvizBracketedString opts mbl tree $ bracketedLinearize pgf lang tree
+
+graphvizBracketedString :: GraphvizOptions -> Maybe Labels -> Tree -> [BracketedString] -> String
+graphvizBracketedString opts mbl tree bss = render graphviz_code
+    where
+      graphviz_code
+          = text "graph {" $$
+            text node_style $$
+            vcat internal_nodes $$
+            (if noLeaves opts then empty
+             else text leaf_style $$
+                  leaf_nodes
+            ) $$ text "}"
+
+      leaf_style = mkOption "edge" "style" (leafEdgeStyle opts) ++
+                   mkOption "edge" "color" (leafColor opts) ++
+                   mkOption "node" "fontcolor" (leafColor opts) ++
+                   mkOption "node" "fontname" (leafFont opts) ++
+                   mkOption "node" "shape" "plaintext"
+
+      node_style = mkOption "edge" "style" (nodeEdgeStyle opts) ++
+                   mkOption "edge" "color" (nodeColor opts) ++
+                   mkOption "node" "fontcolor" (nodeColor opts) ++
+                   mkOption "node" "fontname" (nodeFont opts) ++
+                   mkOption "node" "shape" nodeshape
+          where nodeshape | noFun opts && noCat opts = "point"
+                          | otherwise = "plaintext"
+
+      mkOption object optname optvalue
+          | null optvalue  = ""
+          | otherwise      = object ++ "[" ++ optname ++ "=\"" ++ optvalue ++ "\"]; "
+
+      mkNode fun cat
+          | noFun opts = showCId cat
+          | noCat opts = showCId fun
+          | otherwise  = showCId fun ++ " : " ++ showCId cat
+
+      nil = -1
+      internal_nodes = [mkLevel internals |
+                        internals <- getInternals (map ((,) nil) bss),
+                        not (null internals)]
+      leaf_nodes = mkLevel [(parent, id, mkLeafNode cat word) |
+                            (id, (parent, (cat,word))) <- zip [100000..] (concatMap (getLeaves (mkCId "?") nil) bss)]
+
+      getInternals []    = []
+      getInternals nodes
+          = nub [(parent, fid, mkNode fun cat) |
+                 (parent, Bracket cat fid _ _ fun _ _) <- nodes]
+            : getInternals [(fid, child) |
+                            (_, Bracket _ fid _ _ _ _ children) <- nodes,
+                            child <- children]
+
+      getLeaves cat parent (Leaf word) = [(parent, (cat, word))] -- the lowest cat before the word
+      getLeaves _ parent (Bracket cat fid _ i _ _ children)
+          = concatMap (getLeaves cat fid) children
+
+      mkLevel nodes
+          = text "subgraph {rank=same;" $$
+            nest 2 (-- the following gives the name of the node and its label:
+                    vcat [tag id <> text (mkOption "" "label" lbl) | (_, id, lbl) <- nodes] $$
+                    -- the following is for fixing the order between the children:
+                    (if length nodes > 1 then
+                         text (mkOption "edge" "style" "invis") $$
+                         hsep (intersperse (text " -- ") [tag id | (_, id, _) <- nodes]) <+> semi
+                     else empty)
+                   ) $$
+            text "}" $$
+            -- the following is for the edges between parent and children:
+            vcat [tag pid <> text " -- " <> tag id <> text (depLabel node) | node@(pid, id, _) <- nodes, pid /= nil] $$
+            space
+
+      depLabel node@(parent,id,lbl) 
+        | noDep opts = ";"
+        | otherwise = case getArg id of
+            Just (fun,arg) -> mkOption "" "label" (lookLabel fun arg) 
+            _ -> ";"
+      getArg i = getArgumentPlace i (expr2numtree tree) Nothing
+
+      labels = maybe Map.empty id mbl
+
+      lookLabel fun arg = case Map.lookup fun labels of
+        Just xx | length xx > arg -> case xx !! arg of
+          "head" -> ""
+          l -> l
+        _ -> argLabel fun arg
+      argLabel fun arg = if arg==0 then "" else "dep#" ++ show arg --showCId fun ++ "#" ++ show arg
+                         -- assuming the arg is head, if no configuration is given; always true for 1-arg funs
+      mkLeafNode cat word
+       | noDep opts = word        --- || not (noCat opts) -- show POS only if intermediate nodes hidden
+       | otherwise  = posCat cat ++ "\n" ++ word         -- show POS in dependency tree
+
+      posCat cat = case Map.lookup cat labels of
+        Just [p] -> p
+        _ -> showCId cat
+
+---- to restore the argument place from bracketed linearization
+data NumTree = NumTree Int CId [NumTree]
+
+getArgumentPlace :: Int -> NumTree -> Maybe (CId,Int) -> Maybe (CId,Int)
+getArgumentPlace i tree@(NumTree int fun ts) mfi
+ | i == int  = mfi
+ | otherwise = case [fj | (t,x) <- zip ts [0..], Just fj <- [getArgumentPlace i t (Just (fun,x))]] of
+     fj:_ -> Just fj
+     _ -> Nothing
+
+expr2numtree :: Expr -> NumTree
+expr2numtree = fst . renumber 0 . flatten where
+  flatten e = case e of
+    EApp f a -> case flatten f of
+      NumTree _ g ts -> NumTree 0 g (ts ++ [flatten a])
+    EFun f -> NumTree 0 (CId f) []
+  renumber i t@(NumTree _ f ts) = case renumbers i ts of
+    (ts',j) -> (NumTree j f ts', j+1)
+  renumbers i ts = case ts of
+    t:tt -> case renumber i t of
+      (t',j) -> case renumbers j tt of (tt',k) -> (t':tt',k)
+    _ -> ([],i)
+----- end this terrible stuff AR 4/11/2015
+
+-- alignment in the Graphviz format from the intermediate structure
+-- same effect as the old direct function
+graphvizAlignment :: PGF -> [Language] -> Expr -> String
+graphvizAlignment pgf langs exp =
+  let cncs = [cnc | (l,cnc) <- Map.toList (PGF2.languages pgf)
+                  , CId l `elem` langs]
+  in PGF2.graphvizWordAlignment cncs PGF2.graphvizDefaults exp
+
+gizaAlignment :: PGF -> (Language,Language) -> Expr -> (String,String,String)
+gizaAlignment = error "TODO: gizaAlignment"
+
+
+tag i
+  | i < 0     = char 'r' <> int (negate i)
+  | otherwise = char 'n' <> int i
+
+-- | Generates an exhaustive possibly infinite list of
+-- abstract syntax expressions.
+generateAll :: PGF -> Type -> [Expr]
+generateAll pgf ty = map fst (PGF2.generateAll pgf ty)
+
+-- | A variant of 'generateAll' which also takes as argument
+-- the upper limit of the depth of the generated expression.
+generateAllDepth :: PGF -> Type -> Maybe Int -> [Expr]
+generateAllDepth pgf ty mb_dp = map fst (PGF2.generateAllDepth pgf ty (fromMaybe maxBound mb_dp))
+
+-- | Generates an infinite list of random abstract syntax expressions.
+-- This is usefull for tree bank generation which after that can be used
+-- for grammar testing.
+generateRandom :: RandomGen g => g -> PGF -> Type -> [Expr]
+generateRandom g pgf ty = map fst (PGF2.generateRandom g pgf ty)
+
+-- | A variant of 'generateRandom' which also takes as argument
+-- the upper limit of the depth of the generated expression.
+generateRandomDepth :: RandomGen g => g -> PGF -> Type -> Maybe Int -> [Expr]
+generateRandomDepth g pgf ty mb_dp = map fst (PGF2.generateRandomDepth g pgf ty (fromMaybe maxBound mb_dp))
+
+type Lemma = CId
+type Analysis = String
+
+newtype Morpho = Morpho PGF2.Concr
+
+buildMorpho :: PGF -> Language -> Morpho
+buildMorpho pgf (CId lang) = Morpho $
+  case Map.lookup lang (PGF2.languages pgf) of
+    Just cnc -> cnc
+    Nothing  -> error ("Unknown language: " ++ lang)
+
+lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
+lookupMorpho (Morpho cnc) s =
+  [(CId fun,an) | (fun,an,_) <- PGF2.lookupMorpho cnc s]
+
+morphoMissing  :: Morpho -> [String] -> [String]
+morphoMissing = morphoClassify False
+
+morphoKnown    :: Morpho -> [String] -> [String]
+morphoKnown = morphoClassify True
+
+morphoClassify :: Bool -> Morpho -> [String] -> [String]
+morphoClassify k mo ws = [w | w <- ws, k /= null (lookupMorpho mo w), notLiteral w] where
+  notLiteral w = not (all isDigit w) ---- should be defined somewhere
+
+fullFormLexicon :: Morpho -> [(String,[(Lemma,Analysis)])]
+fullFormLexicon (Morpho cnc) =
+  [(w,[(CId fun,an) | (fun,an,_) <- ans]) | (w,ans) <- PGF2.fullFormLexicon cnc]

src/runtime/haskell/PGF.hsc

@@ -1,116 +0,0 @@
-module PGF ( PGF2.PGF, readPGF
-           , abstractName
-
-           , CId, mkCId, wildCId, showCId, readCId, pIdent
-
-           , PGF2.categories, PGF2.categoryContext, PGF2.startCat
-           , functions, functionsByCat
-
-           , PGF2.Expr(..), PGF2.Literal(..), Tree
-           , PGF2.readExpr, PGF2.showExpr, pExpr
-           , PGF2.mkAbs,    PGF2.unAbs
-           , PGF2.mkApp,    PGF2.unApp, PGF2.unapply
-           , PGF2.mkStr,    PGF2.unStr
-           , PGF2.mkInt,    PGF2.unInt
-           , PGF2.mkDouble, PGF2.unDouble
-           , PGF2.mkFloat,  PGF2.unFloat
-           , PGF2.mkMeta,   PGF2.unMeta
-           , PGF2.exprSize, PGF2.exprFunctions
-
-           , PGF2.Type(..), PGF2.Hypo
-           , PGF2.readType, PGF2.showType
-           , PGF2.mkType, PGF2.unType
-           , PGF2.mkHypo, PGF2.mkDepHypo, PGF2.mkImplHypo
-
-           , PGF2.PGFError(..)
-           ) where
-
-import PGF2.FFI
-
-import Foreign
-import Foreign.C
-import Control.Exception(mask_)
-import Control.Monad
-import qualified PGF2 as PGF2
-import qualified Text.ParserCombinators.ReadP as RP
-import System.IO.Unsafe(unsafePerformIO)
-
-#include <pgf/pgf.h>
-
-newtype CId = CId String deriving (Show,Read,Eq,Ord)
-
-type Language = CId
-
-readPGF = PGF2.readPGF
-
-
-readLanguage = readCId
-showLanguage (CId s) = s
-
-
-abstractName gr = CId (PGF2.abstractName gr)
-
-
-categories gr = map CId (PGF2.categories gr)
-
-
-functions gr  = map CId (PGF2.functions gr)
-functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c)
-
-type Tree = PGF2.Expr
-
-
-mkCId x = CId x
-wildCId = CId "_"
-showCId (CId x) = x
-readCId s = Just (CId s)
-
-
-pIdent :: RP.ReadP String
-pIdent = 
-  liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
-  `mplus`
-  do RP.char '\''
-     cs <- RP.many1 insideChar
-     RP.char '\''
-     return cs
---  where
-insideChar = RP.readS_to_P $ \s ->
-  case s of
-    []             -> []
-    ('\\':'\\':cs) -> [('\\',cs)]
-    ('\\':'\'':cs) -> [('\'',cs)]
-    ('\\':cs)      -> []
-    ('\'':cs)      -> []
-    (c:cs)         -> [(c,cs)]
-
-isIdentFirst c =
-  (c == '_') ||
-  (c >= 'a' && c <= 'z') ||
-  (c >= 'A' && c <= 'Z') ||
-  (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
-isIdentRest c = 
-  (c == '_') ||
-  (c == '\'') ||
-  (c >= '0' && c <= '9') ||
-  (c >= 'a' && c <= 'z') ||
-  (c >= 'A' && c <= 'Z') ||
-  (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
-
-pExpr :: RP.ReadP PGF2.Expr
-pExpr =
-  RP.readS_to_P $ \str ->
-  unsafePerformIO $
-  withText str $ \c_str ->
-  alloca  $ \c_pos ->
-  mask_ $ do
-    c_expr <- pgf_read_expr_ex c_str c_pos unmarshaller
-    if c_expr == castPtrToStablePtr nullPtr
-      then return []
-      else do expr <- deRefStablePtr c_expr
-              freeStablePtr c_expr
-              pos <- peek c_pos
-              size <- ((#peek PgfText, size) c_str) :: IO CSize
-              let c_text = castPtr c_str `plusPtr` (#offset PgfText, text)
-              s    <- peekUtf8CString pos (c_text `plusPtr` fromIntegral size)
-              return [(expr,s)]

src/runtime/haskell/PGF2.hsc

@@ -32,12 +32,13 @@ module PGF2 (-- * PGF
              functionType, functionIsConstructor, functionProbability,
 
              -- ** Expressions
-             Expr(..), Literal(..), showExpr, readExpr,
+             Expr(..), Literal(..), showExpr, showIdent, readExpr, pExpr, pIdent,
              mkAbs,    unAbs, Var,
              mkApp,    unApp, unapply,
              mkVar,    unVar,
              mkStr,    unStr,
              mkInt,    unInt,
+             mkInteger,unInteger,
              mkDouble, unDouble,
              mkFloat,  unFloat,
              mkMeta,   unMeta,
@@ -71,9 +72,7 @@ module PGF2 (-- * PGF
              -- ** Visualizations
              GraphvizOptions(..), graphvizDefaults,
              graphvizAbstractTree, graphvizParseTree,
-             Labels, getDepLabels,
+             graphvizWordAlignment,
-             graphvizDependencyTree, conlls2latexDoc, getCncDepLabels,
-             graphvizWordAlignment, graphvizLRAutomaton,
 
              -- * Concrete syntax
              ConcName,Concr,languages,language,concreteName,languageCode,concreteFlag,
@@ -83,10 +82,10 @@ module PGF2 (-- * PGF
              FId, BracketedString(..), showBracketedString, flattenBracketedString,
              bracketedLinearize, bracketedLinearizeAll,
              hasLinearization, categoryFields,
-             printName, alignWords, gizaAlignment,
+             printName, alignWords,
 
              -- ** Parsing
-             ParseOutput(..), parse, parseWithHeuristics, complete,
+             ParseOutput(..), parse, robustParse, parseWithHeuristics, complete,
 
              -- * Exceptions
              PGFError(..),
@@ -102,7 +101,7 @@ import PGF2.FFI
 
 import Foreign
 import Foreign.C
-import Control.Monad(forM,forM_)
+import Control.Monad(forM,forM_,liftM2,mplus)
 import Control.Exception(bracket,mask_,throwIO)
 import System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO)
 import System.Random
@@ -112,6 +111,7 @@ import Data.List(intersperse,groupBy)
 import Data.Char(isUpper,isSpace,isPunctuation)
 import Data.Maybe(maybe)
 import Text.PrettyPrint
+import qualified Text.ParserCombinators.ReadP as RP
 
 #ifdef __linux__
 #define _GNU_SOURCE
@@ -119,7 +119,10 @@ import Text.PrettyPrint
 #endif
 #include <pgf/pgf.h>
 
--- | Reads a PGF file and keeps it in memory.
+-- | Reads a file in a Portable Grammar Format and produces
+-- a 'PGF' structure. The file is usually produced with:
+--
+-- > $ gf -make <grammar file name>
 readPGF :: FilePath -> IO PGF
 readPGF fpath = readPGFWithProbs fpath Nothing
 
@@ -363,19 +366,14 @@ showPGF p =
           modifyIORef ref (\doc -> doc $$ text def)
 
     ppConcr name c = unsafePerformIO $ do
-      (seq_ids,doc3) <- prepareSequences c -- run first to update all seq_id
+      doc1 <- ppLincats c
-      doc1 <- ppLincats seq_ids c
+      doc2 <- ppLins c
-      doc2 <- ppLins seq_ids c
-      pgf_release_phrasetable_ids seq_ids
       return (text "concrete" <+> text name <+> char '{' $$
               nest 2 (doc1 $$
-                      doc2 $$
+                      doc2) $$
-                      (text "sequences" <+> char '{' $$ 
-                       nest 2 doc3 $$ 
-                       char '}')) $$
               char '}')
 
-    ppLincats seq_ids c = do
+    ppLincats c = do
       ref <- newIORef empty
       (allocaBytes (#size PgfItor) $ \itor ->
        bracket (wrapItorCallback (getLincats ref)) freeHaskellFunPtr $ \fptr ->
@@ -402,15 +400,15 @@ showPGF p =
                                        char ']')
           modifyIORef ref $ (\doc -> doc $$ def)
           forM_ (init [0..n_lindefs]) $ \i -> do
-            def <- bracket (pgf_print_lindef_internal seq_ids val i) free $ \c_text -> do
+            def <- bracket (pgf_print_lindef_internal val i) free $ \c_text -> do
                      fmap text (peekText c_text)
             modifyIORef ref (\doc -> doc $$ text "lindef" <+> def)
           forM_ (init [0..n_linrefs]) $ \i -> do
-            def <- bracket (pgf_print_linref_internal seq_ids val i) free $ \c_text -> do
+            def <- bracket (pgf_print_linref_internal val i) free $ \c_text -> do
                      fmap text (peekText c_text)
             modifyIORef ref $ (\doc -> doc $$ text "linref" <+> def)
 
-    ppLins seq_ids c = do
+    ppLins c = do
       ref <- newIORef empty
       (allocaBytes (#size PgfItor) $ \itor ->
        bracket (wrapItorCallback (getLins ref)) freeHaskellFunPtr $ \fptr ->
@@ -421,30 +419,13 @@ showPGF p =
       where
         getLins :: IORef Doc -> ItorCallback
         getLins ref itor key val exn = do
-          n_prods <- pgf_get_lin_get_prod_count val
+          n_prods <- pgf_get_lin_rules_count val
           forM_ (init [0..n_prods]) $ \i -> do
-            def <- bracket (pgf_print_lin_internal seq_ids val i) free $ \c_text -> do
+            def <- bracket (pgf_print_lin_internal val i) free $ \c_text -> do
                      fmap text (peekText c_text)
             modifyIORef ref (\doc -> doc $$ text "lin" <+> def)
             return ()
 
-    prepareSequences c = do
-      ref <- newIORef empty
-      seq_ids <- (allocaBytes (#size PgfSequenceItor) $ \itor ->
-                  bracket (wrapSequenceItorCallback (getSequences ref)) freeHaskellFunPtr $ \fptr ->
-                  withForeignPtr (c_revision c) $ \c_revision -> do
-                    (#poke PgfSequenceItor, fn) itor fptr
-                    withPgfExn "showPGF" (pgf_iter_sequences (a_db p) c_revision itor nullPtr))
-      doc <- readIORef ref
-      return (seq_ids, doc)
-      where
-        getSequences :: IORef Doc -> SequenceItorCallback
-        getSequences ref itor seq_id val exn = do
-          def <- bracket (pgf_print_sequence_internal seq_id val) free $ \c_text -> do
-                     fmap text (peekText c_text)
-          modifyIORef ref $ (\doc -> doc $$ def)
-          return 0
-
 -- | The abstract language name is the name of the top-level
 -- abstract module
 abstractName :: PGF -> AbsName
@@ -617,7 +598,12 @@ checkContext :: PGF -> [Hypo] -> Either String [Hypo]
 checkContext pgf ctxt = Right ctxt
 
 compute :: PGF -> Expr -> Expr
-compute = error "TODO: compute"
+compute p e =
+  unsafePerformIO $
+  withForeignPtr (a_revision p) $ \c_revision ->
+  bracket (newStablePtr e) freeStablePtr $ \c_e ->
+  bracket (withPgfExn "compute" (pgf_compute (a_db p) c_revision c_e marshaller unmarshaller)) freeStablePtr $ \c_e ->
+    deRefStablePtr c_e
 
 concreteName :: Concr -> ConcName
 concreteName c =
@@ -678,8 +664,6 @@ alignWords c e = unsafePerformIO $
       free ptr
       return (phrase, map fromIntegral fids)
 
-gizaAlignment = error "TODO: gizaAlignment"
-
 -----------------------------------------------------------------------------
 -- Functions using Concr
 -- Morpho analyses, parsing & linearization
@@ -830,8 +814,7 @@ fullFormLexicon c = unsafePerformIO $ do
    withForeignPtr (c_revision c) $ \c_revision -> do
      (#poke PgfSequenceItor,   fn) itor1 fptr1
      (#poke PgfMorphoCallback, fn) itor2 fptr2
-     seq_ids <- withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2)
+     withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2))
-     pgf_release_phrasetable_ids seq_ids)
   fmap (reverse2 []) (readIORef ref)
   where
     getSequences ref _ seq_id val exn = do
@@ -857,29 +840,57 @@ fullFormLexicon c = unsafePerformIO $ do
 
 -- | This data type encodes the different outcomes which you could get from the parser.
 data ParseOutput a
-  = ParseFailed Int String         -- ^ The integer is the position in number of unicode characters where the parser failed.
+  = ParseFailed Int                -- ^ The integer is the position in number of unicode characters where the parser failed.
                                    -- The string is the token where the parser have failed.
   | ParseOk a                      -- ^ If the parsing and the type checking are successful
                                    -- we get the abstract syntax trees as either a list or a chart.
   | ParseIncomplete                -- ^ The sentence is not complete.
+  deriving Show
 
 parse :: Concr -> Type -> String -> ParseOutput [(Expr,Float)]
 parse c ty sent =
   unsafePerformIO $
-  withForeignPtr (c_revision c) $ \c_revision ->
+  withForeignPtr (c_revision c) $ \c_revision_ptr ->
-  bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  allocaBytes (#size PgfExn) $ \c_exn -> do
-  withText sent $ \c_sent -> do
+    c_enum <- bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
-    c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision c_ty marshaller unmarshaller c_sent)
+              withText sent $ \c_sent ->
-    exprs <- enumerateExprs (c_db c) c_enum
+                 pgf_parse (c_db c) c_revision_ptr c_ty marshaller unmarshaller c_sent 0 c_exn
-    return (ParseOk exprs)
+    ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
+    case ex_type of
+      (#const PGF_EXN_NONE) -> do
+         exprs <- enumerateExprs (c_db c) (c_revision c) c_enum
+         return (ParseOk exprs)
+      (#const PGF_EXN_PARSE_ERROR) -> do
+         pos <- (#peek PgfExn, code) c_exn
+         if pos == length sent
+           then return (ParseIncomplete)
+           else return (ParseFailed pos)
+      (#const PGF_EXN_PGF_ERROR) -> do
+         c_msg <- (#peek PgfExn, msg) c_exn
+         msg <- peekCString c_msg
+         free c_msg
+         throwIO (PGFError "parse" msg)
+      _ -> throwIO (PGFError "parse" "An unidentified error occurred")
 
-enumerateExprs c_db c_enum_ptr = do
+robustParse :: Concr -> Type -> String -> [(Expr,Float)]
+robustParse c ty sent =
+  unsafePerformIO $
+  withForeignPtr (c_revision c) $ \c_revision_ptr ->
+  allocaBytes (#size PgfExn) $ \c_exn -> do
+    c_enum <- bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+              withText sent $ \c_sent ->
+              withPgfExn "robustParse" (pgf_parse (c_db c) c_revision_ptr c_ty marshaller unmarshaller c_sent 1)
+    exprs <- enumerateExprs (c_db c) (c_revision c) c_enum
+    return exprs
+
+enumerateExprs c_db c_revision c_enum_ptr = do
   c_enum <- newForeignPtr pgf_free_expr_enum c_enum_ptr
   c_fetch <- (#peek PgfExprEnumVtbl, fetch) =<< (#peek PgfExprEnum, vtbl) c_enum_ptr
   unsafeInterleaveIO (fetchLazy c_fetch c_enum)
   where
     fetchLazy c_fetch c_enum =
-      withForeignPtr c_enum $ \c_enum_ptr -> 
+      withForeignPtr c_revision $ \_ ->
+      withForeignPtr c_enum $ \c_enum_ptr ->
       alloca $ \p_prob -> do
         c_expr <- callFetch c_fetch c_enum_ptr c_db p_prob
         if c_expr == castPtrToStablePtr nullPtr
@@ -1182,11 +1193,11 @@ generateAllExt p ty dp cs
   | otherwise = 
       unsafePerformIO $
       bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
-      withForeignPtr (a_revision p) $ \a_revision ->
+      withForeignPtr (a_revision p) $ \a_revision_ptr ->
       withPgfConcrs cs $ \c_db c_revisions n_revisions ->
       mask_ $ do
-        c_enum <- withPgfExn "generateAllExt" (pgf_generate_all (a_db p) a_revision c_revisions n_revisions c_ty (fromIntegral dp) marshaller unmarshaller)
+        c_enum <- withPgfExn "generateAllExt" (pgf_generate_all (a_db p) a_revision_ptr c_revisions n_revisions c_ty (fromIntegral dp) marshaller unmarshaller)
-        enumerateExprs (a_db p) c_enum
+        enumerateExprs (a_db p) (a_revision p) c_enum
 
 generateAllFrom :: PGF -> Expr -> [(Expr,Float)]
 generateAllFrom p ty = generateAllFromExt p ty maxBound []
@@ -1468,237 +1479,6 @@ graphvizWordAlignment cs opts e =
       then return ""
       else peekText c_text
 
-type Labels = Map.Map Fun [String]
-
-getDepLabels :: String -> Labels
-getDepLabels s = Map.fromList [(f,ls) | f:ls <- map words (lines s)]
-
--- | Visualize word dependency tree.
-graphvizDependencyTree
-  :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@
-  -> Bool -- ^ Include extra information (debug)
-  -> Maybe Labels -- ^ abstract label information obtained with 'getDepLabels'
-  -> Maybe CncLabels -- ^ concrete label information obtained with ' ' (was: unused (was: @Maybe String@))
-  -> Concr
-  -> Expr
-  -> String -- ^ Rendered output in the specified format
-graphvizDependencyTree format debug mlab mclab concr t = error "TODO: graphvizDependencyTree"
-
-graphvizLRAutomaton :: Concr -> String
-graphvizLRAutomaton c =
-  unsafePerformIO $
-  withForeignPtr (c_revision c) $ \c_revision ->
-  bracket (withPgfExn "graphvizLRAutomaton" (pgf_graphviz_lr_automaton (c_db c) c_revision)) free $ \c_text ->
-    if c_text == nullPtr
-      then return ""
-      else peekText c_text
-
----------------------- should be a separate module?
-
--- visualization with latex output. AR Nov 2015
-
-conlls2latexDoc :: [String] -> String
-conlls2latexDoc =
-  render .
-  latexDoc .
-  vcat .
-  intersperse (text "" $+$ app "vspace" (text "4mm")) .
-  map conll2latex .
-  filter (not . null)
-
-conll2latex :: String -> Doc
-conll2latex = ppLaTeX . conll2latex' . parseCoNLL
-
-conll2latex' :: CoNLL -> [LaTeX]
-conll2latex' = dep2latex . conll2dep'
-
-data Dep = Dep {
-    wordLength  :: Int -> Double        -- length of word at position int       -- was: fixed width, millimetres (>= 20.0)
-  , tokens      :: [(String,String)]    -- word, pos (0..)
-  , deps        :: [((Int,Int),String)] -- from, to, label
-  , root        :: Int                  -- root word position
-  }
-
--- some general measures
-defaultWordLength = 20.0  -- the default fixed width word length, making word 100 units
-defaultUnit       = 0.2   -- unit in latex pictures, 0.2 millimetres
-spaceLength       = 10.0
-charWidth = 1.8
-
-wsize rwld  w  = 100 * rwld w + spaceLength                   -- word length, units
-wpos rwld i    = sum [wsize rwld j | j <- [0..i-1]]           -- start position of the i'th word
-wdist rwld x y = sum [wsize rwld i | i <- [min x y .. max x y - 1]]    -- distance between words x and y
-labelheight h  = h + arcbase + 3    -- label just above arc; 25 would put it just below
-labelstart c   = c - 15.0           -- label starts 15u left of arc centre
-arcbase        = 30.0               -- arcs start and end 40u above the bottom
-arcfactor r    = r * 600            -- reduction of arc size from word distance
-xyratio        = 3                  -- width/height ratio of arcs
-
-putArc :: (Int -> Double) -> Int -> Int -> Int -> String -> [DrawingCommand]
-putArc frwld height x y label = [oval,arrowhead,labelling] where
-  oval = Put (ctr,arcbase) (OvalTop (wdth,hght))
-  arrowhead = Put (endp,arcbase + 5) (ArrowDown 5)   -- downgoing arrow 5u above the arc base
-  labelling = Put (labelstart ctr,labelheight (hght/2)) (TinyText label)
-  dxy  = wdist frwld x y             -- distance between words, >>= 20.0
-  ndxy = 100 * rwld * fromIntegral height  -- distance that is indep of word length
-  hdxy = dxy / 2                     -- half the distance
-  wdth = dxy - (arcfactor rwld)/dxy  -- longer arcs are wider in proportion
-  hght = ndxy / (xyratio * rwld)      -- arc height is independent of word length
-  begp = min x y                     -- begin position of oval
-  ctr  = wpos frwld begp + hdxy + (if x < y then 20 else  10)  -- LR arcs are farther right from center of oval
-  endp = (if x < y then (+) else (-)) ctr (wdth/2)            -- the point of the arrow
-  rwld = 0.5 ----
-
-dep2latex :: Dep -> [LaTeX]
-dep2latex d =
-  [Comment (unwords (map fst (tokens d))),
-   Picture defaultUnit (width,height) (
-     [Put (wpos rwld i,0) (Text w) | (i,w) <- zip [0..] (map fst (tokens d))]   -- words
-  ++ [Put (wpos rwld i,15) (TinyText w) | (i,w) <- zip [0..] (map snd (tokens d))]   -- pos tags 15u above bottom
-  ++ concat [putArc rwld (aheight x y) x y label | ((x,y),label) <- deps d]    -- arcs and labels
-  ++ [Put (wpos rwld (root d) + 15,height) (ArrowDown (height-arcbase))]
-  ++ [Put (wpos rwld (root d) + 20,height - 10) (TinyText "ROOT")]
-  )]
- where
-   wld i  = wordLength d i  -- >= 20.0
-   rwld i = (wld i) / defaultWordLength       -- >= 1.0
-   aheight x y = depth (min x y) (max x y) + 1    ---- abs (x-y)
-   arcs = [(min u v, max u v) | ((u,v),_) <- deps d]
-   depth x y = case [(u,v) | (u,v) <- arcs, (x < u && v <= y) || (x == u && v < y)] of ---- only projective arcs counted
-     [] -> 0
-     uvs -> 1 + maximum (0:[depth u v | (u,v) <- uvs])
-   width = {-round-} (sum [wsize rwld w | (w,_) <- zip [0..] (tokens d)]) + {-round-} spaceLength * fromIntegral ((length (tokens d)) - 1)
-   height = 50 + 20 * {-round-} (maximum (0:[aheight x y | ((x,y),_) <- deps d]))
-
-type CoNLL = [[String]]
-parseCoNLL :: String -> CoNLL
-parseCoNLL = map words . lines
-
---conll2dep :: String -> Dep
---conll2dep = conll2dep' . parseCoNLL
-
-conll2dep' :: CoNLL -> Dep
-conll2dep' ls = Dep {
-    wordLength = wld 
-  , tokens = toks
-  , deps = dps
-  , root = head $ [read x-1 | x:_:_:_:_:_:"0":_ <- ls] ++ [1]
-  }
- where
-   wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,pos) = toks !! i in [tok,pos]])
-   toks = [(w,c) | _:w:_:c:_ <- ls]
-   dps = [((read y-1, read x-1),lab) | x:_:_:_:_:_:y:lab:_ <- ls, y /="0"]
-   --maxdist = maximum [abs (x-y) | ((x,y),_) <- dps]
-
-
--- * LaTeX Pictures (see https://en.wikibooks.org/wiki/LaTeX/Picture)
-
--- We render both LaTeX and SVG from this intermediate representation of
--- LaTeX pictures.
-
-data LaTeX = Comment String | Picture UnitLengthMM Size [DrawingCommand]
-data DrawingCommand = Put Position Object
-data Object = Text String | TinyText String | OvalTop Size | ArrowDown Length
-
-type UnitLengthMM = Double
-type Size = (Double,Double)
-type Position = (Double,Double)
-type Length = Double
-
-
--- * latex formatting
-ppLaTeX = vcat . map ppLaTeX1
-  where
-    ppLaTeX1 el =
-      case el of
-        Comment s -> comment s
-        Picture unit size cmds ->
-          app "setlength{\\unitlength}" (text (show unit ++ "mm"))
-          $$ hang (app "begin" (text "picture")<>text (show size)) 2
-                  (vcat (map ppDrawingCommand cmds))
-          $$ app "end" (text "picture")
-          $$ text ""
-
-    ppDrawingCommand (Put pos obj) = put pos (ppObject obj)
-
-    ppObject obj =
-      case obj of
-        Text s -> text s
-        TinyText s -> small (text s)
-        OvalTop size -> text "\\oval" <> text (show size) <> text "[t]"
-        ArrowDown len -> app "vector(0,-1)" (text (show len))
-
-    put p@(_,_) = app ("put" ++ show p)
-    small w = text "{\\tiny" <+> w <> text "}"
-    comment s = text "%%" <+> text s -- line break show follow
-    
-app macro arg = text "\\" <> text macro <> text "{" <> arg <> text "}"
-
-
-latexDoc :: Doc -> Doc
-latexDoc body =
-  vcat [text "\\documentclass{article}",
-        text "\\usepackage[utf8]{inputenc}",
-        text "\\begin{document}",
-        body,
-        text "\\end{document}"]
-
-
-----------------------------------
--- concrete syntax annotations (local) on top of conll
--- examples of annotations:
--- UseComp {"not"} PART neg head 
--- UseComp {*} AUX cop head
-
-type CncLabels = [(String, String -> Maybe (String -> String,String,String))]
--- (fun, word -> (pos,label,target))
--- the pos can remain unchanged, as in the current notation in the article
-
-fixCoNLL :: CncLabels -> CoNLL -> CoNLL
-fixCoNLL labels conll = map fixc conll where
-  fixc row = case row of
-    (i:word:fun:pos:cat:x_:"0":"dep":xs) -> (i:word:fun:pos:cat:x_:"0":"root":xs) --- change the root label from dep to root 
-    (i:word:fun:pos:cat:x_:j:label:xs) -> case look (fun,word) of
-      Just (pos',label',"head") -> (i:word:fun:pos' pos:cat:x_:j :label':xs)
-      Just (pos',label',target) -> (i:word:fun:pos' pos:cat:x_: getDep j target:label':xs)
-      _ -> row
-    _ -> row
-    
-  look (fun,word) = case lookup fun labels of
-    Just relabel -> case relabel word of
-      Just row -> Just row
-      _ -> case lookup "*" labels of
-        Just starlabel -> starlabel word
-        _ -> Nothing
-    _ -> case lookup "*" labels of
-        Just starlabel -> starlabel word
-        _ -> Nothing
-  
-  getDep j label = maybe j id $ lookup (label,j) [((label,j),i) | i:word:fun:pos:cat:x_:j:label:xs <- conll]
-
-getCncDepLabels :: String -> CncLabels
-getCncDepLabels = map merge .  groupBy (\ (x,_) (a,_) -> x == a) . concatMap analyse . filter choose . lines where
-  --- choose is for compatibility with the general notation
-  choose line = notElem '(' line && elem '{' line --- ignoring non-local (with "(") and abstract (without "{") rules
-  
-  analyse line = case break (=='{') line of
-    (beg,_:ws) -> case break (=='}') ws of
-      (toks,_:target) -> case (words beg, words target) of
-        (fun:_,[    label,j]) -> [(fun, (tok, (id,       label,j))) | tok <- getToks toks]
-        (fun:_,[pos,label,j]) -> [(fun, (tok, (const pos,label,j))) | tok <- getToks toks]
-        _ -> []
-      _ -> []
-    _ -> []
-  merge rules@((fun,_):_) = (fun, \tok ->
-    case lookup tok (map snd rules) of
-      Just new -> return new
-      _ -> lookup "*"  (map snd rules)
-    )
-  getToks = words . map (\c -> if elem c "\"," then ' ' else c)
-
-printCoNLL :: CoNLL -> String
-printCoNLL = unlines . map (concat . intersperse "\t")
-
 -----------------------------------------------------------------------
 -- Expressions & types
 
@@ -1741,6 +1521,70 @@ readExpr str =
               freeStablePtr c_expr
               return (Just expr)
 
+pExpr :: RP.ReadP Expr
+pExpr =
+  RP.readS_to_P $ \str ->
+  unsafePerformIO $
+  withText str $ \c_str ->
+  alloca  $ \c_pos ->
+  mask_ $ do
+    c_expr <- pgf_read_expr_ex c_str c_pos unmarshaller
+    if c_expr == castPtrToStablePtr nullPtr
+      then return []
+      else do expr <- deRefStablePtr c_expr
+              freeStablePtr c_expr
+              pos <- peek c_pos
+              size <- ((#peek PgfText, size) c_str) :: IO CSize
+              let c_text = castPtr c_str `plusPtr` (#offset PgfText, text)
+              s    <- peekUtf8CString pos (c_text `plusPtr` fromIntegral size)
+              return [(expr,s)]
+
+pIdent :: RP.ReadP String
+pIdent = 
+  liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
+  `mplus`
+  do RP.char '\''
+     cs <- RP.many1 insideChar
+     RP.char '\''
+     return cs
+
+insideChar = RP.readS_to_P $ \s ->
+  case s of
+    []             -> []
+    ('\\':'\\':cs) -> [('\\',cs)]
+    ('\\':'\'':cs) -> [('\'',cs)]
+    ('\\':cs)      -> []
+    ('\'':cs)      -> []
+    (c:cs)         -> [(c,cs)]
+
+-- | Takes an identifier as a string and adds quotes if necessary
+-- for escaping
+showIdent :: String -> String
+showIdent raw = 
+  if isIdent raw
+    then raw
+    else "'" ++ concatMap escape raw ++ "'"
+  where
+    isIdent []     = False
+    isIdent (c:cs) = isIdentFirst c && all isIdentRest cs
+
+    escape '\'' = "\\\'"
+    escape '\\' = "\\\\"
+    escape c    = [c]
+
+isIdentFirst c =
+  (c == '_') ||
+  (c >= 'a' && c <= 'z') ||
+  (c >= 'A' && c <= 'Z') ||
+  (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
+isIdentRest c = 
+  (c == '_') ||
+  (c == '\'') ||
+  (c >= '0' && c <= '9') ||
+  (c >= 'a' && c <= 'z') ||
+  (c >= 'A' && c <= 'Z') ||
+  (c >= '\192' && c <= '\255' && c /= '\247' && c /= '\215')
+
 -- | renders a type as a 'String'. The list
 -- of identifiers is the list of all free variables
 -- in the type in order reverse to the order

src/runtime/haskell/PGF2/Collab.hsc

@@ -0,0 +1,74 @@
+-------------------------------------------------
+-- |
+-- Module      : PGF2.Colab
+-- Maintainer  : Krasimir Angelov
+-- Stability   : stable
+-- Portability : portable
+--
+-- This module is a server API for implementing
+-- collaborative editing, where the edited document
+-- is continuously parsed.
+-------------------------------------------------
+
+module PGF2.Collab
+         ( ParseChart, parseChart
+         , getParseChartText
+         , Change(..), changeParseChartText
+         ) where
+
+import PGF2.Expr
+import PGF2.FFI
+
+import Foreign
+import Foreign.C
+import Control.Exception(bracket)
+
+#include <pgf/pgf.h>
+
+data ParseChart = ParseChart {ch_db :: Ptr PgfDB,
+                              ch_revision :: ForeignPtr Concr,
+                              ch_chart :: ForeignPtr PgfParseChart
+                             }
+
+parseChart :: Concr -> Type -> String -> IO ParseChart
+parseChart c ty sent =
+  withForeignPtr (c_revision c) $ \c_revision_ptr ->
+  bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  withText sent $ \c_sent -> do
+    c_chart <- withPgfExn "parseChart" (pgf_parse_chart (c_db c) c_revision_ptr c_ty marshaller unmarshaller c_sent 1)
+    fptr <- newForeignPtr pgf_free_parse_chart c_chart
+    return (ParseChart (c_db c) (c_revision c) fptr)
+
+getParseChartText :: ParseChart -> IO String
+getParseChartText (ParseChart c_db c_revision c_chart) =
+  withForeignPtr c_chart $ \c_chart_ptr -> do
+    c_get_text <- (#peek PgfParseChartVtbl, get_text) =<< (#peek PgfParseChart, vtbl) c_chart_ptr
+    c_text <- callGetText c_get_text c_chart_ptr
+    peekText c_text
+
+data Change   = Skip {-# UNPACK #-} !CSize | Change {-# UNPACK #-} !CSize String deriving Show
+
+changeParseChartText :: ParseChart -> [Change] -> IO Bool
+changeParseChartText (ParseChart c_db c_revision c_chart) changes =
+  withForeignPtr c_revision $ \_ ->
+  withForeignPtr c_chart $ \c_chart_ptr -> do
+    c_start <- (#peek PgfParseChartVtbl, start) =<< (#peek PgfParseChart, vtbl) c_chart_ptr
+    callStart c_start c_chart_ptr
+    res <- apply c_chart_ptr changes 
+    c_done <- (#peek PgfParseChartVtbl, done) =<< (#peek PgfParseChart, vtbl) c_chart_ptr
+    callDone c_done c_chart_ptr
+    return res
+  where
+    apply c_chart_ptr []                      = return True
+    apply c_chart_ptr (Skip   i     :changes) = do
+      c_skip <- (#peek PgfParseChartVtbl, skip) =<< (#peek PgfParseChart, vtbl) c_chart_ptr
+      c_res  <- callSkip c_skip c_chart_ptr i
+      if c_res == 0
+        then return False
+        else apply c_chart_ptr changes
+    apply c_chart_ptr (Change i text:changes) = do
+      c_change <- (#peek PgfParseChartVtbl, change) =<< (#peek PgfParseChart, vtbl) c_chart_ptr
+      c_res <- withText text (callChange c_change c_chart_ptr i)
+      if c_res == 0
+        then return False
+        else apply c_chart_ptr changes

src/runtime/haskell/PGF2/Expr.hs

@@ -9,6 +9,7 @@ module PGF2.Expr(Var, Cat, Fun,
                  mkVar,    unVar,
                  mkStr,    unStr,
                  mkInt,    unInt,
+                 mkInteger,unInteger,
                  mkDouble, unDouble,
                  mkFloat,  unFloat,
                  mkMeta,   unMeta,
@@ -133,17 +134,28 @@ unStr (ETyped e ty)   = unStr e
 unStr (EImplArg e)    = unStr e
 unStr _               = Nothing
 
--- | Constructs an expression from integer literal
+-- | Constructs an expression from an int literal
-mkInt :: Integer -> Expr
+mkInt :: Int -> Expr
-mkInt i = ELit (LInt i)
+mkInt i = ELit (LInt (fromIntegral i))
 
--- | Decomposes an expression into integer literal
+-- | Decomposes an expression into an int literal
-unInt :: Expr -> Maybe Integer
+unInt :: Expr -> Maybe Int
-unInt (ELit (LInt i)) = Just i
+unInt (ELit (LInt i)) = Just (fromIntegral i)
 unInt (ETyped e ty)   = unInt e
 unInt (EImplArg e)    = unInt e
 unInt _               = Nothing
 
+-- | Constructs an expression from integer literal
+mkInteger :: Integer -> Expr
+mkInteger i = ELit (LInt i)
+
+-- | Decomposes an expression into integer literal
+unInteger :: Expr -> Maybe Integer
+unInteger (ELit (LInt i)) = Just i
+unInteger (ETyped e ty)   = unInteger e
+unInteger (EImplArg e)    = unInteger e
+unInteger _               = Nothing
+
 -- | Constructs an expression from real number literal
 mkDouble :: Double -> Expr
 mkDouble f = ELit (LFlt f)

src/runtime/haskell/PGF2/FFI.hsc

@@ -48,9 +48,10 @@ data PgfSequenceItor
 data PgfProbsCallback
 data PgfMorphoCallback
 data PgfCohortsCallback
-data PgfPhrasetableIds
 data PgfExprEnum
+data PgfParseChart
 data PgfAlignmentPhrase
+data PgfParseTableMaker
 
 type Wrapper a = a -> IO (FunPtr a)
 type Dynamic a = FunPtr a -> a
@@ -150,26 +151,22 @@ foreign import ccall "wrapper" wrapCohortsCallback :: Wrapper CohortsCallback
 
 foreign import ccall pgf_lookup_cohorts :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfCohortsCallback -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO (Ptr PgfPhrasetableIds)
+foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO ()
 
 foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
 
-foreign import ccall pgf_print_lindef_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
+foreign import ccall pgf_print_lindef_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
 
-foreign import ccall pgf_print_linref_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
+foreign import ccall pgf_print_linref_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
 
-foreign import ccall pgf_get_lin_get_prod_count :: Ptr () -> IO CSize
+foreign import ccall pgf_get_lin_rules_count :: Ptr () -> IO CSize
 
-foreign import ccall pgf_print_lin_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText)
+foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> IO (Ptr PgfText)
-
-foreign import ccall pgf_print_sequence_internal :: CSize -> Ptr () -> IO (Ptr PgfText)
 
 foreign import ccall pgf_sequence_get_text_internal :: Ptr () -> IO (Ptr PgfText)
 
-foreign import ccall pgf_release_phrasetable_ids :: Ptr PgfPhrasetableIds -> IO ()
-
 type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
 
 foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback
@@ -210,6 +207,8 @@ foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Ex
 
 foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
+foreign import ccall pgf_compute :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
+
 foreign import ccall pgf_generate_random :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Type -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
 
 foreign import ccall pgf_generate_random_from :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
@@ -230,9 +229,11 @@ foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText
 
 foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr)
+foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr)
 
-foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr)
+foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr)
+
+foreign import ccall pgf_free_parse_table :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> IO ()
 
 foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
@@ -244,7 +245,7 @@ foreign import ccall "dynamic" callLinBuilder1 :: Dynamic (Ptr PgfLinBuilderIfac
 
 foreign import ccall "dynamic" callLinBuilder2 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr PgfExn -> IO ())
 
-foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
+foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
 
 foreign import ccall "dynamic" callLinBuilder4 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ())
 
@@ -254,13 +255,13 @@ foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIfac
 
 foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO CSize)
 
-foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO ()
 
 foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
@@ -282,11 +283,25 @@ foreign import ccall pgf_bracketed_linearize_all :: Ptr PgfDB -> Ptr Concr -> St
 
 foreign import ccall pgf_align_words :: Ptr PgfDB -> Ptr Concr -> StablePtr Expr -> Ptr PgfPrintContext -> Ptr PgfMarshaller -> Ptr CSize -> Ptr PgfExn -> IO (Ptr (Ptr PgfAlignmentPhrase))
 
-foreign import ccall pgf_parse :: Ptr PgfDB -> Ptr Concr -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfExprEnum)
+foreign import ccall pgf_parse :: Ptr PgfDB -> Ptr Concr -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfText -> CInt -> Ptr PgfExn -> IO (Ptr PgfExprEnum)
+
+foreign import ccall "&pgf_free_expr_enum" pgf_free_expr_enum :: FunPtr (Ptr PgfExprEnum -> IO ())
 
 foreign import ccall "dynamic" callFetch :: Dynamic (Ptr PgfExprEnum -> Ptr PgfDB -> Ptr (#type prob_t) -> IO (StablePtr Expr))
 
-foreign import ccall "&pgf_free_expr_enum" pgf_free_expr_enum :: FunPtr (Ptr PgfExprEnum -> IO ())
+foreign import ccall pgf_parse_chart :: Ptr PgfDB -> Ptr Concr -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfText -> CInt -> Ptr PgfExn -> IO (Ptr PgfParseChart)
+
+foreign import ccall "&pgf_free_parse_chart" pgf_free_parse_chart :: FunPtr (Ptr PgfParseChart -> IO ())
+
+foreign import ccall "dynamic" callGetText :: Dynamic (Ptr PgfParseChart -> IO (Ptr PgfText))
+
+foreign import ccall "dynamic" callStart :: Dynamic (Ptr PgfParseChart -> IO CInt)
+
+foreign import ccall "dynamic" callSkip :: Dynamic (Ptr PgfParseChart -> CSize -> IO CInt)
+
+foreign import ccall "dynamic" callChange :: Dynamic (Ptr PgfParseChart -> CSize -> Ptr PgfText -> IO CInt)
+
+foreign import ccall "dynamic" callDone :: Dynamic (Ptr PgfParseChart -> IO CInt)
 
 foreign import ccall "wrapper" wrapSymbol0 :: Wrapper (Ptr PgfLinearizationOutputIface -> IO ())
 
@@ -318,8 +333,6 @@ foreign import ccall pgf_graphviz_parse_tree :: Ptr PgfDB -> Ptr Concr -> Stable
 
 foreign import ccall pgf_graphviz_word_alignment :: Ptr PgfDB -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> Ptr PgfPrintContext -> Ptr PgfMarshaller -> Ptr PgfGraphvizOptions -> Ptr PgfExn -> IO (Ptr PgfText)
 
-foreign import ccall pgf_graphviz_lr_automaton :: Ptr PgfDB -> Ptr Concr -> Ptr PgfExn -> IO (Ptr PgfText)
-
 
 -----------------------------------------------------------------------
 -- Texts

src/runtime/haskell/PGF2/Transactions.hsc

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}
 module PGF2.Transactions
           ( -- transactions
             TxnID
@@ -18,15 +19,14 @@ module PGF2.Transactions
           , setAbstractFlag
 
             -- concrete syntax
-          , Token, SeqId, LIndex, LVar, LParam(..)
+          , Token, LIndex, LVar, LParam(..)
-          , PArg(..), Symbol(..), Production(..)
+          , PArg(..), Symbol(..), Rule(..)
 
           , createConcrete
           , alterConcrete
           , dropConcrete
           , mergePGF
           , setConcreteFlag
-          , SeqTable
           , createLincat
           , dropLincat
           , createLin, alterLin
@@ -50,27 +50,31 @@ import Data.IORef
 #include <pgf/pgf.h>
 
 newtype Transaction k a =
-  Transaction (Ptr PgfDB -> Ptr PGF -> Ptr k -> Ptr PgfExn -> IO a)
+  Transaction (Ptr PgfDB -> Ptr PGF -> TransactionCtxt k -> Ptr PgfExn -> IO a)
+
+type family TransactionCtxt a
+type instance TransactionCtxt PGF = ()
+type instance TransactionCtxt Concr = (Ptr Concr, Ptr PgfParseTableMaker)
 
 instance Functor (Transaction k) where
-  fmap f (Transaction g) = Transaction $ \c_db c_abstr c_revision c_exn -> do
+  fmap f (Transaction g) = Transaction $ \c_db c_abstr ctxt c_exn -> do
-    res <- g c_db c_abstr c_revision c_exn
+    res <- g c_db c_abstr ctxt c_exn
     return (f res)
 
 instance Applicative (Transaction k) where
-  pure x = Transaction $ \c_db _ c_revision c_exn -> return x
+  pure x = Transaction $ \c_db _ _ c_exn -> return x
   f <*> g = do
     f <- f
     g <- g
     return (f g)
 
 instance Monad (Transaction k) where
-  (Transaction f) >>= g = Transaction $ \c_db c_abstr c_revision c_exn -> do
+  (Transaction f) >>= g = Transaction $ \c_db c_abstr ctxt c_exn -> do
-    res <- f c_db c_abstr c_revision c_exn
+    res <- f c_db c_abstr ctxt c_exn
     ex_type <- (#peek PgfExn, type) c_exn
     if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
       then case g res of
-             Transaction g -> g c_db c_abstr c_revision c_exn
+             Transaction g -> g c_db c_abstr ctxt c_exn
       else return undefined
 
 #if !(MIN_VERSION_base(4,13,0))
@@ -79,7 +83,7 @@ instance Monad (Transaction k) where
 #endif
 
 instance Fail.MonadFail (Transaction k) where
-  fail msg = Transaction $ \c_db c_abstr c_revision c_exn -> fail msg
+  fail msg = Transaction $ \c_db c_abstr ctxt c_exn -> fail msg
 
 data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF)
 
@@ -103,7 +107,7 @@ inTransaction :: TxnID -> Transaction PGF a -> IO a
 inTransaction (TxnID db fptr) (Transaction f) =
   withForeignPtr fptr $ \c_revision -> do
   withPgfExn "inTransaction" $ \c_exn ->
-    f db c_revision c_revision c_exn
+    f db c_revision () c_exn
 
 {- | @modifyPGF gr t@ updates the grammar @gr@ by performing the
    transaction @t@. The changes are applied to the new grammar
@@ -117,7 +121,7 @@ modifyPGF p (Transaction f) =
     c_revision <- pgf_start_transaction (a_db p) c_exn
     ex_type <- (#peek PgfExn, type) c_exn
     if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
-      then do ((restore (f (a_db p) c_revision c_revision c_exn))
+      then do ((restore (f (a_db p) c_revision () c_exn))
                `catch`
                (\e -> do
                     pgf_free_revision_ (a_db p) c_revision
@@ -151,11 +155,11 @@ checkoutPGF p = do
      already a function with the same name then an exception is thrown.
 -}
 createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF Fun
-createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn ->
+createFunction name ty arity bytecode prob = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
   (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> do
-    c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn
+    c_name <- pgf_create_function c_db c_abstr c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn
     if c_name == nullPtr
       then return ""
       else do name  <- peekText c_name
@@ -163,75 +167,78 @@ createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_
               return name
 
 dropFunction :: Fun -> Transaction PGF ()
-dropFunction name = Transaction $ \c_db _ c_revision c_exn ->
+dropFunction name = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-    pgf_drop_function c_db c_revision c_name c_exn
+    pgf_drop_function c_db c_abstr c_name c_exn
 
 createCategory :: Cat -> [Hypo] -> Float -> Transaction PGF ()
-createCategory name hypos prob = Transaction $ \c_db _ c_revision c_exn ->
+createCategory name hypos prob = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   withHypos hypos $ \n_hypos c_hypos -> do
-    pgf_create_category c_db c_revision c_name n_hypos c_hypos prob marshaller c_exn
+    pgf_create_category c_db c_abstr c_name n_hypos c_hypos prob marshaller c_exn
 
 dropCategory :: Cat -> Transaction PGF ()
-dropCategory name = Transaction $ \c_db _ c_revision c_exn ->
+dropCategory name = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-    pgf_drop_category c_db c_revision c_name c_exn
+    pgf_drop_category c_db c_abstr c_name c_exn
 
 createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
-createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
+createConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn ->
-  withText name $ \c_name -> do
+  withText name $ \c_name ->
-  bracketPtr (pgf_create_concrete c_db c_revision c_name c_exn)
+  bracketCnc c_exn
-             (pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
+             (pgf_create_concrete c_db c_abstr c_name)
-    f c_db c_abstr c_concr_revision c_exn
+             (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do
+    f c_db c_abstr ctxt c_exn
 
 alterConcrete :: ConcName -> Transaction Concr a -> Transaction PGF a
-alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn ->
+alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-  bracketPtr (pgf_clone_concrete c_db c_revision c_name c_exn)
+  bracketCnc c_exn
-             (pgf_free_concr_revision_ c_db) $ \c_concr_revision ->
+             (pgf_clone_concrete c_db c_abstr c_name)
-    f c_db c_abstr c_concr_revision c_exn
+             (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do
+    f c_db c_abstr ctxt c_exn
 
-bracketPtr before after thing =
+bracketCnc c_exn before after thing =
+  alloca $ \p_tm ->
   mask $ \restore -> do
-    a <- before
+    c <- before p_tm c_exn
-    if a == nullPtr
+    if c == nullPtr
       then return undefined
-      else do r <- restore (thing a) `onException` after a
+      else do tm <- peek p_tm
-              _ <- after a
+              r <- restore (thing (c,tm)) `onException` after c tm
+              _ <- after c tm
               return r
 
 dropConcrete :: ConcName -> Transaction PGF ()
-dropConcrete name = Transaction $ \c_db _ c_revision c_exn ->
+dropConcrete name = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name -> do
-    pgf_drop_concrete c_db c_revision c_name c_exn
+    pgf_drop_concrete c_db c_abstr c_name c_exn
 
 mergePGF :: FilePath -> Transaction PGF ()
-mergePGF fpath = Transaction $ \c_db _ c_revision c_exn ->
+mergePGF fpath = Transaction $ \c_db c_abstr _ c_exn ->
   withCString fpath $ \c_fpath ->
-    pgf_merge_pgf c_db c_revision c_fpath c_exn
+    pgf_merge_pgf c_db c_abstr c_fpath c_exn
 
 setGlobalFlag :: String -> Literal -> Transaction PGF ()
-setGlobalFlag name value = Transaction $ \c_db _ c_revision c_exn ->
+setGlobalFlag name value = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
-    pgf_set_global_flag c_db c_revision c_name c_value marshaller c_exn
+    pgf_set_global_flag c_db c_abstr c_name c_value marshaller c_exn
 
 setAbstractFlag :: String -> Literal -> Transaction PGF ()
-setAbstractFlag name value = Transaction $ \c_db _ c_revision c_exn ->
+setAbstractFlag name value = Transaction $ \c_db c_abstr _ c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
-    pgf_set_abstract_flag c_db c_revision c_name c_value marshaller c_exn
+    pgf_set_abstract_flag c_db c_abstr c_name c_value marshaller c_exn
 
 setConcreteFlag :: String -> Literal -> Transaction Concr ()
-setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn ->
+setConcreteFlag name value = Transaction $ \c_db _ (c_revision,_) c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
     pgf_set_concrete_flag c_db c_revision c_name c_value marshaller c_exn
 
 type Token  = String
 
-type SeqId  = Int
 type LIndex = Int
 type LVar   = Int
 data LParam  = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)]
@@ -239,7 +246,6 @@ data LParam  = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)]
 
 data Symbol
   = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LParam
-  | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LParam
   | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
   | SymKS Token
   | SymKP [Symbol] [([Symbol],[String])]
@@ -251,22 +257,21 @@ data Symbol
   | SymALL_CAPIT                    -- the special ALL_CAPIT token
   deriving (Eq,Ord,Show)
 
+type Quantifiers = [Int]
+data Rule = Rule Quantifiers LParam [LParam] LParam [Symbol]
+                 deriving (Eq,Ord,Show)
+
 data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
             deriving (Eq,Show)
 
-data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId]
+createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr ()
-                 deriving (Eq,Show)
+createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
-
-type SeqTable = Seq.Seq (Either [Symbol] SeqId)
-
-createLincat :: Cat -> [String] -> [Production] -> [Production] -> SeqTable -> Transaction Concr SeqTable
-createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
   let n_fields = length fields
   in withText name $ \c_name ->
      allocaBytes (n_fields*(#size PgfText*)) $ \c_fields ->
      withTexts c_fields 0 fields $
-     withBuildLinIface (lindefs++linrefs) seqtbl $ \c_build ->
+     withBuildLinIface (lindefs++linrefs) $ \c_build ->
-       pgf_create_lincat c_db c_abstr c_revision c_name
+       pgf_create_lincat c_db c_abstr c_revision tm c_name
                          (fromIntegral n_fields) c_fields
                          (fromIntegral (length lindefs)) (fromIntegral (length linrefs))
                          c_build c_exn
@@ -278,31 +283,29 @@ createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_
         withTexts p (i+1) ss f
 
 dropLincat :: Cat -> Transaction Concr ()
-dropLincat name = Transaction $ \c_db  c_abstr c_revision c_exn ->
+dropLincat name = Transaction $ \c_db  c_abstr (c_revision,tm) c_exn ->
   withText name $ \c_name ->
     pgf_drop_lincat c_db  c_abstr c_revision c_name c_exn
 
-createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
+createLin :: Fun -> [Rule] -> Transaction Concr ()
-createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
+createLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
   withText name $ \c_name ->
-  withBuildLinIface prods seqtbl $ \c_build ->
+  withBuildLinIface rules $ \c_build ->
-    pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
+    pgf_create_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn
 
-alterLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable
+alterLin :: Fun -> [Rule] -> Transaction Concr ()
-alterLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn ->
+alterLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn ->
   withText name $ \c_name ->
-  withBuildLinIface prods seqtbl $ \c_build ->
+  withBuildLinIface rules $ \c_build ->
-    pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn
+    pgf_alter_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn
 
-withBuildLinIface prods seqtbl f = do
+withBuildLinIface rules f = do
-  ref <- newIORef seqtbl
   (allocaBytes (#size PgfBuildLinIface) $ \c_build ->
    allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl ->
-   bracket (wrapLinBuild (build ref)) freeHaskellFunPtr $ \c_callback -> do
+   bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do
      (#poke PgfBuildLinIface, vtbl) c_build vtbl
      (#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback
      f c_build)
-  readIORef ref
   where
     forM_ []     c_exn f = return ()
     forM_ (x:xs) c_exn f = do
@@ -311,39 +314,28 @@ withBuildLinIface prods seqtbl f = do
         then f x >> forM_ xs c_exn f
         else return ()
 
-    build ref _ c_builder c_exn = do
+    build _ c_builder c_exn = do
       vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder
-      forM_ prods c_exn $ \(Production vars args res seqids) -> do
+      forM_ rules c_exn $ \(Rule vars res args lin_idx seq) -> do
-        fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl
+        fun <- (#peek PgfLinBuilderIfaceVtbl, start_rule) vtbl
-        callLinBuilder0 fun c_builder c_exn
+        callLinBuilder2 fun c_builder (fromIntegral (length vars)) (fromIntegral (length seq)) c_exn
         fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl
-        forM_ args c_exn $ \(PArg hypos param) ->
+        forM_ args c_exn $ \arg ->
-          callLParam (callLinBuilder3 fun c_builder (fromIntegral (length hypos))) param c_exn
+          callLParam (callLinBuilder3 fun c_builder) arg c_exn
-        fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl  
+        fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl
-        callLParam (callLinBuilder3 fun c_builder (fromIntegral (length vars))) res c_exn
+        callLParam (callLinBuilder3 fun c_builder) res c_exn
+        fun <- (#peek PgfLinBuilderIfaceVtbl, set_lin_idx) vtbl
+        callLParam (callLinBuilder3 fun c_builder) lin_idx c_exn
         fun <- (#peek PgfLinBuilderIfaceVtbl, add_variable) vtbl
-        forM_ vars c_exn $ \(v,r) ->
+        forM_ vars c_exn $ \r ->
-          callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn
+          callLinBuilder1 fun c_builder (fromIntegral r) c_exn
-        fun <- (#peek PgfLinBuilderIfaceVtbl, add_sequence_id) vtbl
+        forM_ seq c_exn (addSymbol c_builder vtbl c_exn)
-        seqtbl <- readIORef ref
+        fun <- (#peek PgfLinBuilderIfaceVtbl, end_rule) vtbl
-        forM_ seqids c_exn $ \seqid ->
-          case Seq.index seqtbl seqid of
-            Left syms   -> do fun    <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl
-                              callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn
-                              forM_ syms c_exn (addSymbol c_builder vtbl c_exn)
-                              fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl
-                              seqid' <- callLinBuilder7 fun c_builder c_exn
-                              writeIORef ref $! Seq.update seqid (Right (fromIntegral seqid')) seqtbl
-            Right seqid -> do callLinBuilder1 fun c_builder (fromIntegral seqid) c_exn
-        fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl
         callLinBuilder0 fun c_builder c_exn
 
     addSymbol c_builder vtbl c_exn (SymCat d r) = do
       fun <- (#peek PgfLinBuilderIfaceVtbl, add_symcat) vtbl
       callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn
-    addSymbol c_builder vtbl c_exn (SymLit d r) = do
-      fun <- (#peek PgfLinBuilderIfaceVtbl, add_symlit) vtbl
-      callLParam (callLinBuilder4 fun c_builder (fromIntegral d)) r c_exn
     addSymbol c_builder vtbl c_exn (SymVar d r) = do
       fun <- (#peek PgfLinBuilderIfaceVtbl, add_symvar) vtbl
       callLinBuilder2 fun c_builder (fromIntegral d) (fromIntegral r) c_exn
@@ -406,12 +398,12 @@ withBuildLinIface prods seqtbl f = do
           pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms
 
 dropLin :: Fun -> Transaction Concr ()
-dropLin name = Transaction $ \c_db c_abstr c_revision c_exn ->
+dropLin name = Transaction $ \c_db c_abstr (c_revision,_) c_exn ->
   withText name $ \c_name ->
     pgf_drop_lin c_db c_abstr c_revision c_name c_exn
 
 setPrintName :: Fun -> String -> Transaction Concr ()
-setPrintName fun name = Transaction $ \c_db _ c_revision c_exn ->
+setPrintName fun name = Transaction $ \c_db _ (c_revision,_) c_exn ->
   withText fun $ \c_fun ->
   withText name $ \c_name -> do
     pgf_set_printname c_db c_revision c_fun c_name c_exn
@@ -434,7 +426,7 @@ getFunctionType fun = Transaction $ \c_db c_revision _ c_exn -> do
 -- | A monadic version of 'categoryFields' which returns the fields of
 -- a category from grammar in the current transaction.
 getCategoryFields :: Cat -> Transaction Concr (Maybe [String])
-getCategoryFields cat = Transaction $ \c_db _ c_revision c_exn ->
+getCategoryFields cat = Transaction $ \c_db _ (c_revision,_) c_exn ->
   withText cat $ \c_cat ->
   alloca $ \p_n_fields -> do
     c_fields <- pgf_category_fields c_db c_revision c_cat p_n_fields c_exn

src/runtime/haskell/pgf2.cabal

@@ -23,6 +23,7 @@ library
   exposed-modules:
     PGF2,
     PGF2.Transactions,
+    PGF2.Collab,
     PGF2.ByteCode,
     -- backwards compatibility API:
     PGF
@@ -74,6 +75,16 @@ test-suite linearization
     containers,
     pgf2
 
+test-suite parsing
+  type: exitcode-stdio-1.0
+  main-is: tests/parsing.hs
+  default-language: Haskell2010
+  build-depends:
+    base,
+    HUnit >= 1.6.1.0,
+    containers,
+    pgf2
+
 test-suite typechecking
   type: exitcode-stdio-1.0
   main-is: tests/typechecking.hs

src/runtime/haskell/tests/basic.pmcfg

@@ -19,48 +19,40 @@ concrete basic_cnc {
   lincat Float = [
            "s"
          ]
-  lindef Float(0) -> Float[String(0)] = [S0]
+  lindef Float(0) -> Float[String(0)]; 0 : <0,0>
-  linref String(0) -> Float[Float(0)] = [S0]
+  linref String(0) -> Float[Float(0)]; 0 : <0,0>
   lincat Int = [
            "s"
          ]
-  lindef Int(0) -> Int[String(0)] = [S0]
+  lindef Int(0) -> Int[String(0)]; 0 : <0,0>
-  linref String(0) -> Int[Int(0)] = [S0]
+  linref String(0) -> Int[Int(0)]; 0 : <0,0>
   lincat N = [
            "s"
          ]
-  lindef N(0) -> N[String(0)] = [S0]
+  lindef N(0) -> N[String(0)]; 0 : <0,0>
-  linref {i<2} . String(0) -> N[N(i)] = [S0]
+  linref {i<2} String(0) -> N[N(i)]; 0 : <0,0>
   lincat P = [
            "s"
          ]
-  lindef P(0) -> P[String(0)] = [S0]
+  lindef P(0) -> P[String(0)]; 0 : <0,0>
-  linref String(0) -> P[P(0)] = [S0]
+  linref String(0) -> P[P(0)]; 0 : <0,0>
   lincat S = [
            ""
          ]
-  lindef S(0) -> S[String(0)] = [S0]
+  lindef S(0) -> S[String(0)]; 0 : <0,0>
-  linref String(0) -> S[S(0)] = [S0]
+  linref String(0) -> S[S(0)]; 0 : <0,0>
   lincat String = [
            "s"
          ]
-  lindef String(0) -> String[String(0)] = [S0]
+  lindef String(0) -> String[String(0)]; 0 : <0,0>
-  linref String(0) -> String[String(0)] = [S0]
+  linref String(0) -> String[String(0)]; 0 : <0,0>
-  lin {i<2} . S(0) -> c[N(i)] = [S0]
+  lin {i<2} S(0) -> c[N(i)]; 0 : <0,0>
-  lin S(0) -> floatLit[Float(0)] = [S0]
+  lin S(0) -> floatLit[Float(0)]; 0 : <0,0>
-  lin {i<2} . P(0) -> ind[P(0),P(0),N(i)] = [S1]
+  lin {i<2} P(0) -> ind[P(0),P(0),N(i)]; 0 : <0,0> "&" "λ" SOFT_BIND <1,$0> SOFT_BIND "," SOFT_BIND <1,$1> "." <1,0>
-  lin S(0) -> intLit[Int(0)] = [S0]
+  lin S(0) -> intLit[Int(0)]; 0 : <0,0>
-  lin {i<2} . P(0) -> nat[N(i)] = [S5]
+  lin {i<2} P(0) -> nat[N(i)]; 0 : "nat" SOFT_BIND "(" SOFT_BIND <0,0> SOFT_BIND ")"
-  lin N(0) -> s[N(0)] = [S2]
+  lin N(0) -> s[N(1)]; 0 : "1"
-  lin N(0) -> s[N(1)] = [S4]
+  lin N(0) -> s[N(0)]; 0 : <0,0> "+" "1"
-  lin S(0) -> stringLit[String(0)] = [S0]
+  lin S(0) -> stringLit[String(0)]; 0 : <0,0>
-  lin N(1) -> z[] = [S3]
+  lin N(1) -> z[]; 0 : "0"
-  sequences {
-    S0 = <0,0>
-    S1 = <0,0> "&" "λ" SOFT_BIND <1,$0> SOFT_BIND "," SOFT_BIND <1,$1> "." <1,0>
-    S2 = <0,0> "+" "1"
-    S3 = "0"
-    S4 = "1"
-    S5 = "nat" SOFT_BIND "(" SOFT_BIND <0,0> SOFT_BIND ")"
-  }
 }