added MonadFix and fix how return is defined

majestic: fix bubbling + type annotations for option metadata

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

@@ -12,7 +12,6 @@ jobs:
     name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
     runs-on: ${{ matrix.os }}
     strategy:
-      fail-fast: false
       matrix:
         os: [ubuntu-latest, macos-latest, windows-latest]
         cabal: ["latest"]
@@ -20,26 +19,21 @@ jobs:
           - "8.6.5"
           - "8.8.3"
           - "8.10.7"
-          - "9.6.7"
         exclude:
           - os: macos-latest
             ghc: 8.8.3
           - os: macos-latest
             ghc: 8.6.5
-          - os: macos-latest
-            ghc: 8.10.7
           - os: windows-latest
             ghc: 8.8.3
           - os: windows-latest
             ghc: 8.6.5
-          - os: windows-latest
-            ghc: 8.10.7
 
     steps:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: haskell-actions/setup@v2
+    - uses: haskell/actions/setup@v1.2.9
       id: setup-haskell-cabal
       name: Setup Haskell
       with:
@@ -50,7 +44,7 @@ jobs:
       run: |
         cabal freeze
 
-    - uses: actions/cache@v4
+    - uses: actions/cache@v1
       name: Cache ~/.cabal/store
       with:
         path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
@@ -68,18 +62,18 @@ jobs:
 
   stack:
     name: stack / ghc ${{ matrix.ghc }}
-    runs-on: ${{ matrix.ghc == '7.10.3' && 'ubuntu-20.04' || 'ubuntu-latest' }}
+    runs-on: ubuntu-latest
     strategy:
-      fail-fast: false
       matrix:
         stack: ["latest"]
-        ghc: ["8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2", "9.6.7"]
+        ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2"]
+        # ghc: ["8.8.3"]
 
     steps:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: haskell-actions/setup@v2
+    - uses: haskell/actions/setup@v1.2.9
       name: Setup Haskell Stack
       with:
         ghc-version: ${{ matrix.ghc }}
@@ -91,7 +85,7 @@ jobs:
     - run: sed -i.bak 's/"C compiler link flags", "/&-no-pie /' /home/runner/.ghcup/ghc/7.10.3/lib/ghc-7.10.3/settings
       if: matrix.ghc == '7.10.3'
 
-    - uses: actions/cache@v4
+    - uses: actions/cache@v1
       name: Cache ~/.stack
       with:
         path: ~/.stack
@@ -101,7 +95,8 @@ jobs:
 
     - name: Build
       run: |
-        stack build --test --no-run-tests --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
+        stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
+        # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
 
     - name: Test
       run: |

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

.github/workflows/build-majestic.yml

@@ -0,0 +1,369 @@
+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
+
+    steps:
+    - uses: actions/checkout@v3
+
+    - name: Build runtime
+      working-directory: ./src/runtime/c
+      run: |
+        autoreconf -i
+        ./configure
+        make
+        make install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@v3
+      with:
+        name: libpgf-linux
+        path: |
+          /usr/local/lib/libpgf*
+          /usr/local/include/pgf
+
+  linux-haskell:
+    name: Haskell (Linux)
+    runs-on: ubuntu-latest
+    needs: linux-runtime
+
+    steps:
+    - uses: actions/checkout@v3
+    - name: Download artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: libpgf-linux
+    - run: |
+        sudo mv lib/* /usr/local/lib/
+        sudo mv include/* /usr/local/include/
+
+    - name: Setup Haskell
+      uses: haskell/actions/setup@v2
+      with:
+        ghc-version: 8
+
+    - 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 --extra-lib-dirs=/usr/local/lib
+        cabal test --extra-lib-dirs=/usr/local/lib
+
+    - name: build the compiler
+      working-directory: ./src/compiler
+      run: |
+        cabal v1-install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@master
+      with:
+        name: compiler-linux
+        path: |
+          ~/.cabal/bin/gf
+
+  linux-python:
+    name: Python (Linux)
+    runs-on: ubuntu-latest
+    needs: linux-runtime
+
+    steps:
+    - uses: actions/checkout@v3
+    - name: Download artifact
+      uses: actions/download-artifact@v3
+      with:
+        name: libpgf-linux
+
+    - name: Install cibuildwheel
+      run: |
+        python3 -m pip install git+https://github.com/joerick/cibuildwheel.git@main
+
+    - name: Install and test bindings
+      env:
+        CIBW_BEFORE_BUILD: cp -r lib/* /usr/lib/ && cp -r include/* /usr/include/
+        CIBW_TEST_REQUIRES: pytest
+        CIBW_TEST_COMMAND: "pytest {project}/src/runtime/python"
+        CIBW_SKIP: "pp* *i686 *musllinux_x86_64"
+      run: |
+        python3 -m cibuildwheel src/runtime/python --output-dir wheelhouse
+
+    - uses: actions/upload-artifact@master
+      with:
+        name: python-linux
+        path: ./wheelhouse
+
+#  linux-javascript:
+#    name: JavaScript (Linux)
+#    runs-on: ubuntu-latest
+#    needs: linux-runtime
+#
+#    steps:
+#    - uses: actions/checkout@v3
+#    - name: Download artifact
+#      uses: actions/download-artifact@master
+#      with:
+#        name: libpgf-linux
+#    - run: |
+#        sudo mv lib/* /usr/local/lib/
+#        sudo mv include/* /usr/local/include/
+#
+#    - name: Setup Node.js
+#      uses: actions/setup-node@v2
+#      with:
+#        node-version: '12'
+#
+#    - name: Install dependencies
+#      working-directory: ./src/runtime/javascript
+#      run: |
+#        npm ci
+#
+#    - name: Run testsuite
+#      working-directory: ./src/runtime/javascript
+#      run: |
+#        npm run test
+
+# ----------------------------------------------------------------------------
+
+  macos-runtime:
+    name: Runtime (macOS)
+    runs-on: macOS-11
+
+    steps:
+    - uses: actions/checkout@v3
+
+    - name: Install build tools
+      run: |
+        brew install \
+          autoconf \
+          automake \
+          libtool \
+
+    - name: Build runtime
+      working-directory: ./src/runtime/c
+      run: |
+        glibtoolize
+        autoreconf -i
+        ./configure
+        make
+        sudo make install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@master
+      with:
+        name: libpgf-macos
+        path: |
+          /usr/local/lib/libpgf*
+          /usr/local/include/pgf
+
+  macos-haskell:
+    name: Haskell (macOS)
+    runs-on: macOS-11
+    needs: macos-runtime
+
+    steps:
+    - uses: actions/checkout@v3
+    - name: Download artifact
+      uses: actions/download-artifact@master
+      with:
+        name: libpgf-macos
+    - run: |
+        sudo mv lib/* /usr/local/lib/
+        sudo mv include/* /usr/local/include/
+
+    - name: Setup Haskell
+      uses: haskell/actions/setup@v2
+      with:
+        ghc-version: 8
+
+    - name: Build & run testsuite
+      working-directory: ./src/runtime/haskell
+      run: |
+        cabal test --extra-lib-dirs=/usr/local/lib
+
+  macos-python:
+    name: Python (macOS)
+    runs-on: macOS-11
+    needs: macos-runtime
+    env:
+      EXTRA_INCLUDE_DIRS: /usr/local/include
+      EXTRA_LIB_DIRS: /usr/local/lib
+      MACOSX_DEPLOYMENT_TARGET: 11.0
+  
+    steps:
+    - uses: actions/checkout@v3
+    - name: Download artifact
+      uses: actions/download-artifact@master
+      with:
+        name: libpgf-macos
+    - run: |
+        sudo mv lib/* /usr/local/lib/
+        sudo mv include/* /usr/local/include/
+
+    - name: Install cibuildwheel
+      run: |
+        python3 -m pip install git+https://github.com/joerick/cibuildwheel.git@main
+
+    - name: Install and test bindings
+      env:
+        CIBW_TEST_REQUIRES: pytest
+        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
+
+    - uses: actions/upload-artifact@master
+      with:
+        name: python-macos
+        path: ./wheelhouse
+
+#  macos-javascript:
+#   name: JavaScript (macOS)
+#    runs-on: macOS-11
+#    needs: macos-runtime
+#
+#    steps:
+#    - uses: actions/checkout@v3
+#    - name: Download artifact
+#      uses: actions/download-artifact@master
+#      with:
+#        name: libpgf-macos
+#    - run: |
+#        sudo mv lib/* /usr/local/lib/
+#        sudo mv include/* /usr/local/include/
+#
+#    - name: Setup Node.js
+#      uses: actions/setup-node@v2
+#      with:
+#        node-version: '12'
+#
+#    - name: Install dependencies
+#      working-directory: ./src/runtime/javascript
+#      run: |
+#        npm ci
+#
+#    - name: Run testsuite
+#      working-directory: ./src/runtime/javascript
+#      run: |
+#        npm run test
+
+# ----------------------------------------------------------------------------
+
+  mingw64-runtime:
+    name: Runtime (MinGW64)
+    runs-on: windows-latest
+
+    steps:
+    - uses: actions/checkout@v3
+    
+    - name: Setup MSYS2
+      uses: msys2/setup-msys2@v2
+      with:
+        msystem: MINGW64
+        install: >-
+          base-devel
+          autoconf
+          automake
+          libtool
+          mingw-w64-x86_64-toolchain
+          mingw-w64-x86_64-libtool
+
+    - name: Build runtime
+      shell: msys2 {0}
+      working-directory: ./src/runtime/c
+      run: |
+        autoreconf -i
+        ./configure
+        make
+        make install
+
+    - name: Upload artifact
+      uses: actions/upload-artifact@master
+      with:
+        name: libpgf-windows
+        path: |
+          ${{runner.temp}}/msys64/mingw64/bin/libpgf*
+          ${{runner.temp}}/msys64/mingw64/bin/libgcc_s_seh-1.dll
+          ${{runner.temp}}/msys64/mingw64/bin/libstdc++-6.dll
+          ${{runner.temp}}/msys64/mingw64/bin/libwinpthread-1.dll
+          ${{runner.temp}}/msys64/mingw64/lib/libpgf*
+          ${{runner.temp}}/msys64/mingw64/include/pgf
+
+  windows-python:
+    name: Python (Windows)
+    runs-on: windows-latest
+
+    steps:
+    - uses: actions/checkout@v3
+
+    - name: Setup Python
+      uses: actions/setup-python@v4
+      with:
+        python-version: '3.10'
+
+    - name: Install cibuildwheel
+      run: |
+        python3 -m pip install git+https://github.com/joerick/cibuildwheel.git@main
+
+    - name: Install and test bindings
+      env:
+        CIBW_TEST_REQUIRES: pytest
+        CIBW_TEST_COMMAND: "pytest   {project}\\src\\runtime\\python"
+        CIBW_SKIP: "pp* *-win32"
+      run: |
+        python3 -m cibuildwheel src\runtime\python --output-dir wheelhouse
+
+    - uses: actions/upload-artifact@master
+      with:
+        name: python-windows
+        path: ./wheelhouse
+
+  upload_pypi:
+    name: Upload to PyPI
+    needs: [linux-python, macos-python, windows-python]
+    runs-on: ubuntu-latest
+    if: github.ref == 'refs/heads/majestic' && github.event_name == 'push'
+
+    steps:
+      - uses: actions/checkout@v3
+
+      - name: Set up Python
+        uses: actions/setup-python@v3
+        with:
+          python-version: '3.x'
+
+      - name: Install twine
+        run: pip install twine
+
+      - uses: actions/download-artifact@master
+        with:
+          name: python-linux
+          path: ./dist
+
+      - uses: actions/download-artifact@master
+        with:
+          name: python-macos
+          path: ./dist
+
+      - uses: actions/download-artifact@master
+        with:
+          name: python-windows
+          path: ./dist
+
+      - name: Publish
+        env:
+          TWINE_USERNAME: __token__
+          TWINE_PASSWORD: ${{ secrets.pypi_majestic_password }}
+        run: |
+          (cd ./src/runtime/python && curl -I --fail https://pypi.org/project/$(python setup.py --name)/$(python setup.py --version)/) || twine upload --skip-existing dist/*

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

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

.gitignore

@@ -5,6 +5,7 @@
 *.jar
 *.gfo
 *.pgf
+*.ngf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf
@@ -46,6 +47,8 @@ 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
@@ -53,6 +56,12 @@ 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
@@ -73,9 +82,3 @@ 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

CHANGELOG.md

@@ -1,7 +1,6 @@
-### New since 3.12 (WIP)
+### New since 3.11 (WIP)
 
-### 3.12
-See <https://www.grammaticalframework.org/download/release-3.12.html>
+- Added a changelog!
 
 ### 3.11
 

Makefile

@@ -6,41 +6,30 @@ VERSION=$(shell sed -ne "s/^version: *\([0-9.]*\).*/\1/p" gf.cabal)
 # Check if stack is installed
 STACK=$(shell if hash stack 2>/dev/null; then echo "1"; else echo "0"; fi)
 
-# Check if cabal >= 2.4 is installed (with v1- and v2- commands)
-CABAL_NEW=$(shell if cabal v1-repl --help >/dev/null 2>&1 ; then echo "1"; else echo "0"; fi)
-
 ifeq ($(STACK),1)
   CMD=stack
 else
   CMD=cabal
-  ifeq ($(CABAL_NEW),1)
-    CMD_PFX=v1-
-  endif
+  CMD_OPT="--force-reinstalls"
 endif
 
-all: build
+all: src/runtime/c/libpgf.la
+	${CMD} install gf
 
-dist/setup-config: gf.cabal Setup.hs WebSetup.hs
-ifneq ($(STACK),1)
-	cabal ${CMD_PFX}configure
-endif
+src/runtime/c/libpgf.la: src/runtime/c/Makefile
+	(cd src/runtime/c; make; sudo make install)
 
-build: dist/setup-config
-	${CMD} ${CMD_PFX}build
+src/runtime/c/Makefile: src/runtime/c/Makefile.in src/runtime/c/configure
+	(cd src/runtime/c; ./configure)
 
-install:
-ifeq ($(STACK),1)
-	stack install
-else
-	cabal ${CMD_PFX}copy
-	cabal ${CMD_PFX}register
-endif
+src/runtime/c/Makefile.in src/runtime/c/configure: src/runtime/c/configure.ac src/runtime/c/Makefile.am
+	(cd src/runtime/c; autoreconf -i)
 
 doc:
-	${CMD} ${CMD_PFX}haddock
+	${CMD} haddock
 
 clean:
-	${CMD} ${CMD_PFX}clean
+	${CMD} clean
 	bash bin/clean_html
 
 html::
@@ -50,7 +39,7 @@ html::
 # number to the top of debian/changelog.
 # (Tested on Ubuntu 15.04. You need to install dpkg-dev & debhelper.)
 deb:
-	dpkg-buildpackage -b -uc -d
+	dpkg-buildpackage -b -uc
 
 # Make a macOS installer package
 pkg:

README.md

@@ -2,6 +2,8 @@
 
 # Grammatical Framework (GF)
 
+![Build majestic runtime](https://github.com/GrammaticalFramework/gf-core/actions/workflows/build-majestic.yml/badge.svg?branch=majestic)
+
 The Grammatical Framework is a grammar formalism based on type theory.
 It consists of:
 
@@ -30,29 +32,42 @@ GF particularly addresses four aspects of grammars:
 
 ## Compilation and installation
 
-The simplest way of installing GF from source is with the command:
+1. First, you need to install the C Runtime. 
+```Bash
+cd src/runtime/c
 ```
-cabal install
-```
-or:
-```
-stack install
-```
-Note that if you are unlucky to have Cabal 3.0 or later, then it uses
-the so-called Nix style commands. Using those for GF development is
-a pain. Every time when you change something in the source code, Cabal
-will generate a new folder for GF to look for the GF libraries and
-the GF cloud. Either reinstall everything with every change in the
-compiler, or be sane and stop using cabal-install. Instead you can do:
-```
-runghc Setup.hs configure
+Then follow the instructions in the [README.md](src/runtime/c/README.md) in that folder.
+
+2. When the C runtime is installed, you should set up the Haskell runtime
+```Bash
+cd ../haskell
+runghc Setup.hs configure 
 runghc Setup.hs build
 sudo runghc Setup.hs install
 ```
-The script will install the GF dependencies globally. The only solution
-to the Nix madness that I found is radical:
+If the above commands fail because of missing dependencies, then you must install those first. Use something along the lines:
+```Bash
+cabal v1-install random --global
+```
+the same applies for all other dependecies needed here or bellow.
 
-  "No person, no problem" (Нет человека – нет проблемы).
+If you use macOS, you might run into problems with installation under ``/usr/lib``, and you should **first** specify the variable for the library path: 
+```Bash
+export DYLD_LIBRARY_PATH=/usr/local/lib
+```
+and then you run following commands:
+```Bash
+runghc Setup.hs configure --prefix=/usr/local
+runghc Setup.hs build
+sudo DYLD_LIBRARY_PATH=/usr/local/lib runghc Setup.hs install
+```
+3. Then you need to setup the compiler: 
+```Bash
+cd ../../compiler/           
+runghc Setup.hs configure
+runghc Setup.hs build
+sudo DYLD_LIBRARY_PATH=/usr/local/lib runghc Setup.hs install
+```
 
 For more information, including links to precompiled binaries, see the [download page](https://www.grammaticalframework.org/download/index.html).
 

ServerInstructions.md

@@ -0,0 +1,18 @@
+# GF server installation
+
+1. First make sure your compiler is installed with a flag server: 
+
+```bash
+cd gf-core/src/compiler/           
+runghc Setup.hs configure -f servef
+runghc Setup.hs build
+sudo runghc Setup.hs install
+```
+
+1. You can test it now by running: 
+
+```bash
+gf -server
+```
+
+It will also show the root directory (`ROOT_DIR`)

Setup.hs

@@ -1,96 +0,0 @@
-import Distribution.System(Platform(..),OS(..))
-import Distribution.Simple(defaultMainWithHooks,UserHooks(..),simpleUserHooks)
-import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),absoluteInstallDirs,datadir)
-import Distribution.Simple.Setup(BuildFlags(..),Flag(..),InstallFlags(..),CopyDest(..),CopyFlags(..),SDistFlags(..))
-import Distribution.PackageDescription(PackageDescription(..),emptyHookedBuildInfo)
-import Distribution.Simple.BuildPaths(exeExtension)
-import System.Directory
-import System.FilePath((</>),(<.>))
-import System.Process
-import Control.Monad(forM_,unless)
-import Control.Exception(bracket_)
-import Data.Char(isSpace)
-
-import WebSetup
-
-main :: IO ()
-main = defaultMainWithHooks simpleUserHooks
-  { preConf   = gfPreConf
-  , preBuild  = gfPreBuild
-  , postBuild = gfPostBuild
-  , preInst   = gfPreInst
-  , postInst  = gfPostInst
-  , postCopy  = gfPostCopy
-  }
-  where
-    gfPreConf args flags = do
-      pkgs <- fmap (map (dropWhile isSpace) . tail . lines)
-                   (readProcess "ghc-pkg" ["list"] "")
-      forM_ dependencies $ \pkg -> do
-        let name = takeWhile (/='/') (drop 36 pkg)
-        unless (name `elem` pkgs) $ do
-          let fname = name <.> ".tar.gz"
-          callProcess "wget" [pkg,"-O",fname]
-          callProcess "tar"  ["-xzf",fname]
-          removeFile fname
-          bracket_ (setCurrentDirectory name) (setCurrentDirectory ".." >> removeDirectoryRecursive name) $ do
-            exists <- doesFileExist "Setup.hs"
-            unless exists $ do
-              writeFile "Setup.hs" (unlines [
-                  "import Distribution.Simple",
-                  "main = defaultMain"
-                ])
-            let to_descr = reverse .
-                           (++) (reverse ".cabal") . 
-                           drop 1 . 
-                           dropWhile (/='-') . 
-                           reverse
-            callProcess "wget"   [to_descr pkg, "-O", to_descr name]
-            callProcess "runghc" ["Setup.hs","configure"]
-            callProcess "runghc" ["Setup.hs","build"]
-            callProcess "sudo" ["runghc","Setup.hs","install"]
-          
-      preConf simpleUserHooks args flags
-
-    gfPreBuild args = gfPre args . buildDistPref
-    gfPreInst  args = gfPre args . installDistPref
-
-    gfPre args distFlag = do
-      return emptyHookedBuildInfo
-
-    gfPostBuild args flags pkg lbi = do
-      let gf = default_gf lbi
-      buildWeb gf flags (pkg,lbi)
-
-    gfPostInst args flags pkg lbi = do
-      installWeb (pkg,lbi)
-
-    gfPostCopy args flags  pkg lbi = do
-      copyWeb flags (pkg,lbi)
-
-    -- `cabal sdist` will not make a proper dist archive, for that see `make sdist`
-    -- However this function should exit quietly to allow building gf in sandbox
-    gfSDist pkg lbi hooks flags = do
-      return ()
-
-dependencies = [
-  "https://hackage.haskell.org/package/utf8-string-1.0.2/utf8-string-1.0.2.tar.gz",
-  "https://hackage.haskell.org/package/json-0.10/json-0.10.tar.gz",
-  "https://hackage.haskell.org/package/network-bsd-2.8.1.0/network-bsd-2.8.1.0.tar.gz",
-  "https://hackage.haskell.org/package/httpd-shed-0.4.1.1/httpd-shed-0.4.1.1.tar.gz",
-  "https://hackage.haskell.org/package/exceptions-0.10.5/exceptions-0.10.5.tar.gz",
-  "https://hackage.haskell.org/package/stringsearch-0.3.6.6/stringsearch-0.3.6.6.tar.gz",
-  "https://hackage.haskell.org/package/multipart-0.2.1/multipart-0.2.1.tar.gz",
-  "https://hackage.haskell.org/package/cgi-3001.5.0.0/cgi-3001.5.0.0.tar.gz"
-  ]
-
--- | Get path to locally-built gf
-default_gf :: LocalBuildInfo -> FilePath
-default_gf lbi = buildDir lbi </> exeName' </> exeNameReal
-  where
-    -- shadows Distribution.Simple.BuildPaths.exeExtension, which changed type signature in Cabal 2.4
-    exeExtension = case hostPlatform lbi of
-      Platform arch Windows -> "exe"
-      _ -> ""
-    exeName' = "gf"
-    exeNameReal = exeName' <.> exeExtension

WebSetup.hs

@@ -1,146 +0,0 @@
-module WebSetup(buildWeb,installWeb,copyWeb,numJobs,execute) where
-
-import System.Directory(createDirectoryIfMissing,copyFile,doesDirectoryExist,doesFileExist)
-import System.FilePath((</>),dropExtension)
-import System.Process(rawSystem)
-import System.Exit(ExitCode(..))
-import Distribution.Simple.Setup(BuildFlags(..),Flag(..),CopyFlags(..),CopyDest(..),copyDest)
-import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..),datadir,buildDir,absoluteInstallDirs)
-import Distribution.PackageDescription(PackageDescription(..))
-
-{-
-   To test the GF web services, the minibar and the grammar editor, use
-   "cabal install" (or "runhaskell Setup.hs install") to install gf as usual.
-   Then start the server with the command "gf -server" and open
-   http://localhost:41296/ in your web browser (Firefox, Safari, Opera or
-   Chrome). The example grammars listed below will be available in the minibar.
--}
-
-{-
-  Update 2018-07-04
-
-  The example grammars have now been removed from the GF repository.
-  This script will look for them in ../gf-contrib and build them from there if possible.
-  If not, the user will be given a message and nothing is build or copied.
-  (Unfortunately cabal install seems to hide all messages from stdout,
-  so users won't see this message unless they check the log.)
--}
-
--- | Notice about contrib grammars
-noContribMsg :: IO ()
-noContribMsg = putStr $ unlines
-  [ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
-  , "If you want them to be built, clone the following repository in the same directory as gf-core:"
-  , "https://github.com/GrammaticalFramework/gf-contrib.git"
-  ]
-
-example_grammars :: [(String, String, [String])] -- [(pgf, subdir, source modules)]
-example_grammars =
-   [("Letter.pgf","letter",letterSrc)
-   ,("Foods.pgf","foods",foodsSrc)
-   ,("Phrasebook.pgf","phrasebook",phrasebookSrc)
-   ]
-  where
-    foodsSrc = ["Foods"++lang++".gf"|lang<-foodsLangs]
-    foodsLangs = words "Afr Amh Bul Cat Cze Dut Eng Epo Fin Fre Ger Gle Heb Hin Ice Ita Jpn Lav Mlt Mon Nep Pes Por Ron Spa Swe Tha Tsn Tur Urd"
-
-    phrasebookSrc = ["Phrasebook"++lang++".gf"|lang<-phrasebookLangs]
-    phrasebookLangs = words "Bul Cat Chi Dan Dut Eng Lav Hin Nor Spa Swe Tha" -- only fastish languages
-
-    letterSrc = ["Letter"++lang++".gf"|lang<-letterLangs]
-    letterLangs = words "Eng Fin Fre Heb Rus Swe"
-
-contrib_dir :: FilePath
-contrib_dir = ".."</>"gf-contrib"
-
-buildWeb :: String -> BuildFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
-buildWeb gf flags (pkg,lbi) = do
-  contrib_exists <- doesDirectoryExist contrib_dir
-  if contrib_exists
-  then mapM_ build_pgf example_grammars
-  -- else noContribMsg
-  else return ()
-  where
-    gfo_dir = buildDir lbi </> "examples"
-
-    build_pgf :: (String, String, [String]) -> IO Bool
-    build_pgf (pgf,subdir,src) =
-      do createDirectoryIfMissing True tmp_dir
-         putStrLn $ "Building "++pgf
-         execute gf args
-      where
-        tmp_dir = gfo_dir</>subdir
-        dir = contrib_dir</>subdir
-        dest = NoCopyDest
-        gf_lib_path = datadir (absoluteInstallDirs pkg lbi dest) </> "lib"
-        args = numJobs flags++["-make","-s"] -- ,"-optimize-pgf"
-               ++["--gfo-dir="++tmp_dir,
-                --"--gf-lib-path="++gf_lib_path,
-                  "--name="++dropExtension pgf,
-                  "--output-dir="++gfo_dir]
-               ++[dir</>file|file<-src]
-
-installWeb :: (PackageDescription, LocalBuildInfo) -> IO ()
-installWeb = setupWeb NoCopyDest
-
-copyWeb :: CopyFlags -> (PackageDescription, LocalBuildInfo) -> IO ()
-copyWeb flags = setupWeb dest
-  where
-    dest = case copyDest flags of
-             NoFlag -> NoCopyDest
-             Flag d -> d
-
-setupWeb :: CopyDest -> (PackageDescription, LocalBuildInfo) -> IO ()
-setupWeb dest (pkg,lbi) = do
-  mapM_ (createDirectoryIfMissing True) [grammars_dir,cloud_dir]
-  contrib_exists <- doesDirectoryExist contrib_dir
-  if contrib_exists
-  then mapM_ copy_pgf example_grammars
-  else return () -- message already displayed from buildWeb
-  copyGFLogo
-  where
-    grammars_dir = www_dir </> "grammars"
-    cloud_dir = www_dir </> "tmp" -- hmm
-    logo_dir = www_dir </> "Logos"
-    www_dir = datadir (absoluteInstallDirs pkg lbi dest) </> "www"
-    gfo_dir = buildDir lbi </> "examples"
-
-    copy_pgf :: (String, String, [String]) -> IO ()
-    copy_pgf (pgf,subdir,_) =
-      do let src = gfo_dir </> pgf
-         let dst = grammars_dir </> pgf
-         ex <- doesFileExist src
-         if ex then do putStrLn $ "Installing "++dst
-                       copyFile src dst
-               else putStrLn $ "Not installing "++dst
-
-    gf_logo = "gf0.png"
-
-    copyGFLogo =
-      do createDirectoryIfMissing True logo_dir
-         copyFile ("doc"</>"Logos"</>gf_logo) (logo_dir</>gf_logo)
-
--- | Run an arbitrary system command, returning False on failure
-execute :: String -> [String] -> IO Bool
-execute command args =
-  do let cmdline = command ++ " " ++ unwords (map showArg args)
-     e <- rawSystem command args
-     case e of
-       ExitSuccess   -> return True
-       ExitFailure i -> do putStrLn $ "Ran: " ++ cmdline
-                           putStrLn $ command++" exited with exit code: " ++ show i
-                           return False
-  where
-    showArg arg = if ' ' `elem` arg then "'" ++ arg ++ "'" else arg
-
--- | This function is used to enable parallel compilation of the RGL and example grammars
-numJobs :: BuildFlags -> [String]
-numJobs flags =
-    if null n
-    then ["-j","+RTS","-A20M","-N","-RTS"]
-    else ["-j="++n,"+RTS","-A20M","-N"++n,"-RTS"]
-  where
-    -- buildNumJobs is only available in Cabal>=1.20
-    n = case buildNumJobs flags of
-          Flag mn | mn/=Just 1-> maybe "" show mn
-          _ -> ""

bin/build-binary-dist.sh

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

debian/changelog

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

debian/control

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

debian/rules

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

doc/gf-editor-modes.md

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

doc/gf-editor-modes.t2t

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

doc/gf-help-full.txt

@@ -46,7 +46,7 @@
 #TINY
 
 The command has one argument which is either function, expression or
-a category defined in the abstract syntax of the current grammar.
+a category defined in the abstract syntax of the current grammar. 
 If the argument is a function then ?its type is printed out.
 If it is a category then the category definition is printed.
 If a whole expression is given it prints the expression with refined
@@ -303,7 +303,7 @@ but the resulting .gf file must be imported separately.
 
 #TINY
 
-Generates a list of random trees, by default one tree up to depth 5.
+Generates a list of random trees, by default one tree.
 If a tree argument is given, the command completes the Tree with values to
 all metavariables in the tree. The generation can be biased by probabilities,
 given in a file in the -probs flag.
@@ -315,14 +315,13 @@ given in a file in the -probs flag.
  | ``-cat`` | generation category
  | ``-lang`` | uses only functions that have linearizations in all these languages
  | ``-number`` | number of trees generated
- | ``-depth`` | the maximum generation depth (default: 5)
+ | ``-depth`` | the maximum generation depth
  | ``-probs`` | file with biased probabilities (format 'f 0.4' one by line)
 
 - Examples:
 
  | ``gr`` | one tree in the startcat of the current grammar
  | ``gr -cat=NP -number=16`` | 16 trees in the category NP
- | ``gr -cat=NP -depth=2`` | one tree in the category NP, up to depth 2
  | ``gr -lang=LangHin,LangTha -cat=Cl`` | Cl, both in LangHin and LangTha
  | ``gr -probs=FILE`` | generate with bias
  | ``gr (AdjCN ? (UseN ?))`` | generate trees of form (AdjCN ? (UseN ?))
@@ -339,8 +338,8 @@ given in a file in the -probs flag.
 
 #TINY
 
-Generates all trees of a given category. By default,
-the depth is limited to 5, but this can be changed by a flag.
+Generates all trees of a given category. By default, 
+the depth is limited to 4, but this can be changed by a flag.
 If a Tree argument is given, the command completes the Tree with values
 to all metavariables in the tree.
 
@@ -354,7 +353,7 @@ to all metavariables in the tree.
 
 - Examples:
 
- | ``gt`` | all trees in the startcat, to depth 5
+ | ``gt`` | all trees in the startcat, to depth 4
  | ``gt -cat=NP -number=16`` | 16 trees in the category NP
  | ``gt -cat=NP -depth=2`` | trees in the category NP to depth 2
  | ``gt (AdjCN ? (UseN ?))`` | trees of form (AdjCN ? (UseN ?))
@@ -583,7 +582,7 @@ trees where a function node is a metavariable.
 
 - Examples:
 
- | ``l -lang=LangSwe,LangNor -chunks ? a b (? c d)`` |
+ | ``l -lang=LangSwe,LangNor -chunks ? a b (? c d)`` | 
 
 
 #NORMAL
@@ -648,7 +647,7 @@ The -lang flag can be used to restrict this to fewer languages.
 The default start category can be overridden by the -cat flag.
 See also the ps command for lexing and character encoding.
 
-The -openclass flag is experimental and allows some robustness in
+The -openclass flag is experimental and allows some robustness in 
 the parser. For example if -openclass="A,N,V" is given, the parser
 will accept unknown adjectives, nouns and verbs with the resource grammar.
 

doc/gf-refman.md

@@ -1224,14 +1224,15 @@ modules.
 
 Here are some flags commonly included in grammars.
 
-  flag         value                description                        module
-  ------------ -------------------- ---------------------------------- ----------
-  `coding`     character encoding   encoding used in string literals   concrete
-  `startcat`   category             default target of parsing          abstract
+  flag             value                description                        module
+  ------------     -------------------- ---------------------------------- ----------
+  `coding`         character encoding   encoding used in string literals   concrete
+  `startcat`       category             default target of parsing          abstract
+  `case_sensitive` on/off               controlls the case sensitiveness   concrete
 
 The possible values of these flags are specified [here](#flagvalues).
 Note that the `lexer` and `unlexer` flags are deprecated. If you need
-their functionality, you should use supply them to GF shell commands
+their functionality, you should supply them to GF shell commands
 like so:
 
     put_string -lextext "страви, напої" | parse
@@ -2294,6 +2295,12 @@ for parsing, random generation, and any other grammar operation that
 depends on category. Its legal values are the categories defined or
 inherited in the abstract syntax.
 
+The flag `case_sensitive` has value `on` by default which means that
+the parser will always match the input with the grammar predictions
+in a case sensitive manner. This can be overriden by setting the flag
+to `off`. The flag also controlls how the linearizer matches the
+prefixes in the `pre` construction.
+
 
 ### Compiler pragmas
 

doc/hackers-guide/CompilationOverview.md

@@ -0,0 +1,11 @@
+# Compilation
+
+The GF language is designed to be easy for the programmers to use but be able to run it efficiently we need to reduce it to a more low-level language. The goal of this chapter is to give an overview of the different steps in the compilation. The program transformation goes throught the following phases:
+
+- renaming - here all identifiers in the grammar are made explicitly qualified. For example, if you had used the identifier PredVP somewhere, the compiler will search for a definition of that identifier in either the current module or in any of the modules imported from the current one. If a definition is found in, say in a module called Sentence, then the unqualified name PredVP will be replaced with the explicit qualification Sentence.PredVP. On the other hand, if the source program is already using an explicit qualification like Sentence.PredVP, then the compiler will check whether PredVP is indeed defined in the module Sentence. 
+
+- type checking - here the compiler will check whether all functions and variables are used correctly with respect to their types. For each term that the compiler checks it will also generate a new version of the term after the type checking. The input and output terms may not need to be the same. For example, the compiler may insert explicit type information. It might fill-in implicit arguments, or it may instantiate meta variables.
+
+- partial evaluation - here is where the real compilation starts. The compiler will fully evaluate the term for each linearization to a normal. In the process, all uses of operations will be inlined. This is part of reducing the GF language to a simpler language which does not support operations.
+
+- PMCFG generation - the language that the GF runtime understands is an extension of the PMCFG formalism. Not all features permitted in the GF language are allowed on that level. Most of the uses for that extra features have been eliminated via partial evaluation. If there are any left, then the compilation will abort. The main purpose of the PMCFG generation is to get rid of most of the parameter types in the source grammar. That is possible by generating several specialized linearization rules from a single linearization rule in the source.

doc/hackers-guide/DESIDERATA.md

@@ -0,0 +1,51 @@
+This is an experiment to develop **a majestic new GF runtime**.
+
+The reason is that there are several features that we want to have and they all require a major rewrite of the existing C runtime.
+Instead of beating the old code until it starts doing what we want, it is time to start from scratch.
+
+# New Features
+
+The features that we want are:
+
+- We want to support **even bigger grammars that don't fit in the main memory** anymore. Instead, they should reside on the disc and parts will be loaded on demand.
+The current design is that all memory allocated for the grammars should be from memory-mapped files. In this way the only limit for the grammar size will
+be the size of the virtual memory, i.e. 2^64 bytes. The swap file is completely circumvented, while all of the available RAM can be used as a cache for loading parts
+of the grammar.
+
+- We want to be able to **update grammars dynamically**. This is a highly desired feature since recompiling large grammars takes hours.
+Instead, dynamic updates should happen instantly.
+
+- We want to be able to **store additional information in the PGF**. For example that could be application specific semantic data.
+Another example is to store the source code of the different grammar rules, to allow the compiler to recompile individual rules.
+
+- We want to **allow a single file to contain slightly different versions of the grammar**. This will be a kind of a version control system,
+which will allow different users to store their own grammar extensions while still using the same core content.
+
+- We want to **avoid the exponential explosion in the size of PMCFG** for some grammars. This happens because PMCFG as a formalism is too low-level.
+By enriching it with light-weight variables, we can make it more powerful and hopefully avoid the exponential explosion.
+
+- We want to finally **ditch the old Haskell runtime** which has long outlived its time.
+
+There are also two bugs in the old C runtime whose fixes will require a lot of changes, so instead of fixing the old runtime we do it here:
+
+- **Integer literals in the C runtime** are implemented as 32-bit integers, while the Haskell runtime used unlimited integers.
+Python supports unlimited integers too, so it would be nice to support them in the new runtime as well.
+
+- The old C runtime assumed that **String literals are terminated with the NULL character**. None of the modern languages (Haskell, Python, Java, etc) make
+that assumption, so we should drop it too.
+
+# Consequences
+
+The desired features will have the following implementation cosequences.
+
+- The switch from memory-based to disc-based runtime requires one big change. Before it was easy to just keep a pointer from one object to another.
+Unfortunately this doesn't work with memory-mapped files, since every time when you map a file into memory it may end up at a different virtual address.
+Instead we must use file offsets. In order to make programming simpler, the new runtime will be **implemented in C++ instead of C**. This allows us to overload
+the arrow operator (`->`) which will dynamically convert file offsets to in-memory pointers.
+
+- The choice of C++ also allows us to ditch the old `libgu` library and **use STL** instead.
+
+- The content of the memory mapped files is platform-specific. For that reason there will be two grammar representations:
+     - **Native Grammar Format** (`.ngf`) - which will be instantly loadable by just mapping it to memory, but will be platform-dependent.
+     - **Portable Grammar Format** (`.pgf`) - which will take longer to load but will be more compact and platform independent.
+  The runtime will be able to load `.pgf` files and convert them to `.ngf`. Conversely `.pgf` can be exported from the current `.ngf`.

doc/hackers-guide/LambdaCalculus.md

@@ -0,0 +1,217 @@
+The concrete syntax in GF is expressed in a special kind of functional language. Unlike in other functional languages, all GF programs are computed at compile time. The result of the computation is another program in a simplified formalized called Parallel Multiple Context-Free Grammar (PMCFG). More on that later. For now we will only discuss how the computations in a GF program work.
+
+At the heart of the GF compiler is the so called partial evaluator. It computes GF terms but it also have the added super power to be able to work with unknown variables. Consider for instance the term ``\s -> s ++ ""``. A normal evaluator cannot do anything with it, since in order to compute the value of the lambda function, you need to know the value of ``s``. In the computer science terminology the term is already in its normal form. A partial evaluator on the other hand, will just remember that ``s`` is a variable with an unknown value and it will try to compute the expression in the body of the function. After that it will construct a new function where the body is precomputed as much as it goes. In the concrete case the result will be ``\s -> s``, since adding an empty string to any other string produces the same string.
+
+Another super power of the partial evaluator is that it can work with meta variables. The syntax for meta variables in GF is ``?0, ?1, ?2, ...``, and they are used as placeholders which mark parts of the program that are not finished yet. The partial evaluator has no problem to work with such incomplete programs. Sometimes the result of the computation depends on a yet unfinished part of the program, then the evaluator just suspends the computation. In other cases, the result is completely independent of the existance of metavariables. In the later, the evaluator will just return the result.
+
+One of the uses of the evaluator is during type checking where we must enforce certain constraints. The constraints may for instance indicate that the only way for them to be satisfied is to assign a fixed value to one or more of the meta variables. The partial evaluator does that as well. Another use case is during compilation to PMCFG. The compiler to PMCFG, in certain cases assigns to a metavariable all possible values that the variable may have and it then produces different results.
+
+In the rest of we will discuss the implementation of the partial evaluator.
+
+# Simple Lambda Terms
+
+We will start with the simplest possible subset of the GF language, also known as simple lambda calculus. It is defined as an algebraic data type in Haskell, as follows:
+```Haskell
+data Term
+  = Vr Ident           -- i.e. variables: x,y,z ...
+  | Cn Ident           -- i.e. constructors: cons, nil, etc.
+  | App Term Term      -- i.e. function application: @f x@
+  | Abs Ident Term     -- i.e. \x -> t
+```
+The result from the evaluation of a GF term is either a constructor applied to a list of other values, or an unapplied lambda abstraction:
+```Haskell
+type Env = [(Ident,Value)]
+data Value
+  = VApp Ident [Value]   -- i.e. constructor application
+  | VClosure Env Term    -- i.e. a closure contains an environment and the term for a lambda abstraction
+  | VGen Int [Value]     -- we will also need that special kind of value for the partial evaluator
+```
+For the lambda abstractions we build a closure which preserves the environment as it was when we encountered the abstraction. That is necessary since its body may contain free variables whose values are defined in the environment.
+
+The evaluation itself is simple:
+```Haskell
+eval env (Vr x)          args = apply (lookup x env) args
+eval env (Cn c)          args = VApp c args
+eval env (App t1 t2)     args = eval env t1 (eval env t2 : args)
+eval env (Abs x t)         [] = VClosure env (Abs x t)
+eval env (Abs x t) (arg:args) = eval ((x,v):env) t args
+
+apply (VApp c vs)                    args = VApp c (vs++args)
+apply (VClosure env (Abs x t)) (arg:args) = eval ((x,arg):env) t args
+apply (VGen i vs)                    args = VGen i (vs++args)
+```
+Here the we use the `apply` function to apply an already evaluated term to a list of arguments.
+
+When we talk about functional languages, we usually discuss the evaluation order and we differentiate between about lazy and strict languages. Simply speaking, a strict language evaluates the arguments of a function before the function is called. In a lazy language, on the other hand, the arguments are passed unevaluated and are computed only if the value is really needed for the execution of the function. The main advantage of lazy languages is that they guarantee the termination of the computation in some cases where strict languages don't. The GF language does not allow recursion and therefore all programs terminate. Looking from only that angle it looks like the evaluation order is irrelevant in GF. Perhaps that is also the reason why this has never been discussed before. The question, however, becomes relevant again if we want to have an optimal semantics for variants. As we will see in the next section, the only way to get that is if we define GF as a lazy language.
+
+After that discussion, there is an interesting question. Does the eval/apply implementation above define a strict or a lazy language? We have the rule:
+```Haskell
+eval env (App t1 t2)  vs  = eval env t1 (eval env t2 : vs)
+```
+where we see that when a term `t1` is applied to a term `t2` then both get evaluated. The answer to the question then depends on the semantics of the implementation language. Since the evaluation is implemented in Haskell, `eval env t2` would not be computed unless if its value is really neeeded. Therefore, our implementation defines a new lazy language. On the other hand, if the same algorithm is directly transcribed in ML then it will define a strict one instead of a lazy one.
+
+So far we only defined the evaluator which does the usual computations, but it still can't simplify terms like ``\s -> s ++ ""`` where the simplification happens under the lambda abstraction. The normal evaluator would simply return the abstraction unchanged. To take the next step, we also need a function which takes a value and produces a new term which is precomputed as much as possible:
+```Haskell
+value2term i (VApp c vs) =
+  foldl (\t v -> App t (value2term i v)) (Cn c) vs
+value2term i (VGen j vs) =
+  foldl (\t v -> App t (value2term i v)) (Vr ('v':show j)) vs
+value2term i (VClosure env (Abs x t)) =
+  let v = eval ((x,VGen i []):env) t []
+  in Abs ('v':show i) (value2term (i+1) v)
+```
+The interesting rule here is how closures are turned back to terms. We simply evaluate the body of the lambda abstraction with an environment which binds the variable with the special value `VGen i []`. That value stands for the free variable bound by the `i`-th lambda abstraction counted from the outset of the final term inwards. The only thing that we can do with a free variable is to apply it to other values and this is exactly what `apply` does above. After we evaluate the body of the lambda abstraction, the final value is turned back to a term and we reapply a lambda abstraction on top of it. Note that here we also use `i` as a way to generate fresh variables. Whenever, `value2term` encounters a `VGen` it concerts it back to a variable, i.e. `Vr ('v':show j)`.
+
+Given the two functions `eval` and `value2term`, a partial evaluator is defined as:
+```Haskell
+normalForm t = value2term 0 (eval [] t [])
+```
+
+Of course the rules above describe only the core of a functional language. If we really want to be able to simplify terms like ``\s -> s ++ ""``, then we must
+add string operations as well. The full implementation of GF for instance knows that an empty string concatenated with any other value results in the same value. This is true even if the other value is actually a variable, i.e. a `VGen` in the internal representation. On the other hand, it knows that pattern matching on a variable is impossible to precompute. In other words, the partial evaluator would leave the term:
+```GF
+\x -> case x of {
+        _+"s" -> x+"'"
+        _     -> x+"'s"
+      }
+```
+unchanged since it can't know whether the value of `x` ends with `"s"`.
+
+# Variants
+
+GF supports variants which makes its semantics closer to the language [Curry](https://en.wikipedia.org/wiki/Curry_(programming_language)) than to Haskell. We support terms like `("a"|"b")` which are used to define equivalent linearizations for one and the same semantic term. Perhaps the most prototypical example is for spelling variantions. For instance, if we want to blend British and American English into the same language then we can use `("color"|"colour")` whenever either of the forms is accepted.
+
+The proper implementation for variants complicates the semantics of the language a lot. Consider the term `(\x -> x + x) ("a"|"b")`! Its value depends on whether our language is defined as lazy or strict. In a strict language, we will first evaluate the argument:
+```GF
+   (\x -> x + x) ("a"|"b")
+=> ((\x -> x + x) "a") | ((\x -> x + x) "b")
+=> ("a"+"a") | ("b"+"b")
+=> ("aa"|"bb")
+```
+and therefore there are only two values `"aa"´ and `"bb"´. On the other hand in a lazy language, we will do the function application first:
+```GF
+   (\x -> x + x) ("a"|"b")
+=> ("a"|"b") + ("a"|"b")
+=> ("aa"|"ab"|"ba"|"bb")
+```
+and get four different values. The experience shows that a semantics producing only two values is more useful since it gives us a way to control how variants are expanded. If you want the same variant to appear in two different places, just bind the variant to a variable first! It looks like a strict evaluation order has an advantage here. Unfortunately that is not always the case. Consider another example, in a strict order:
+```GF
+   (\x -> "c") ("a"|"b")
+=> ((\x -> "c") "a") | ((\x -> "c") "b")
+=> ("c" | "c")
+```
+Here we get two variants with one and the same value "c". A lazy evaluation order would have avoided the redundancy since `("a"|"b")` would never have been computed.
+
+The best strategy is to actually use lazy evaluation but not to treat the variants as values. Whenever we encounter a variant term, we just split the evaluation in two different branches, one for each variant. At the end of the computation, we get a set of values which does not contain variants. The partial evaluator converts each value back to a term and combines all terms back to a single one by using a top-level variant. The first example would then compute as:
+```GF
+   (\x -> x + x) ("a"|"b")
+=> x + x where x = ("a"|"b")
+
+-- Branch 1:
+=> x + x where x = "a"
+=> "a" + "a" where x = "a"
+=> "aa"
+
+-- Branch 2:
+=> x + x where x = "b"
+=> "b" + "b" where x = "b"
+=> "bb"
+```
+Here the first step proceeds without branching. We just compute the body of the lambda function while remembering that `x` is bound to the unevaluated term `("a"|"b")`. When we encounter the concatenation `x + x`, then we actually need the value of `x`. Since it is bound to a variant, we must split the evaluation into two branches. In each branch `x` is rebound to either of the two variants `"a"` or `"b"`. The partial evaluator would then recombine the results into `"aa"|"bb"`.
+
+If we consider the second example, it will proceed as:
+```GF
+   (\x -> "c") ("a"|"b")
+=> "c" where x = ("a"|"b")
+=> "c"
+```
+since we never ever needed the value of `x`.
+
+There are a lot of other even more interesting examples when we take into account that GF also supports record types and parameter types. Consider this:
+```GF
+   (\x -> x.s1+x.s1) {s1="s"; s2="a"|"b"}
+=> x.s1+x.s1 where x = {s1="s"; s2="a"|"b"}
+=> "s"+"s"
+=> "ss"
+```
+Here when we encounter `x.s1`, we must evaluate `x` and then its field `s1` but not `s2`. Therefore, there is only one variant. On the other hand, here:
+```GF
+   (\x -> x.s2+x.s2) {s1="s"; s2="a"|"b"}
+=> x.s2+x.s2 where x = {s1="s"; s2="a"|"b"}
+
+-- Branch 1
+x.s2+x.s2 where x = {s1="s"; s2="a"}
+"a"+"a"
+"aa"
+
+-- Branch 2
+x.s2+x.s2 where x = {s1="s"; s2="b"}
+"b"+"b"
+"bb"
+```
+we branch only after encountering the variant in the `s2` field.
+
+The implementation for variants requires the introduction of a nondeterministic monad with a support for mutable variables. See this [paper](https://gup.ub.gu.se/file/207634):
+
+Claessen, Koen & Ljunglöf, Peter. (2000). Typed Logical Variables in Haskell. Electronic Notes Theoretical Computer Science. 41. 37. 10.1016/S1571-0661(05)80544-4.
+
+for possible implementations. Our concrete implemention is built on top of the `ST` monad in Haskell and provides the primitives:
+```Haskell
+newThunk :: Env s -> Term -> EvalM s (Thunk s)
+newEvaluatedThunk :: Value s -> EvalM s (Thunk s)
+force :: Thunk s -> EvalM s (Value s)
+msum :: [EvalM s a] -> EvalM s a
+runEvalM :: (forall s . EvalM s a) -> [a]
+```
+Here, a `Thunk` is either an unevaluated term or an already computed value. Internally, it is implement as an `STRef`. If the thunk is unevaluated, it can be forced to an evaluated state by calling `force`. Once a thunk is evaluated, it remains evaluated forever. `msum`, on the other hand, makes it possible to nondeterministically branch into a list of possible actions. Finally, `runEvalM` takes a monadic action and returns the list of all possible results.
+
+The terms and the values in the extended language are similar with two exceptions. We add the constructor `FV` for encoding variants in the terms, and the constructors for values now take lists of thunks instead of values:
+```Haskell
+data Term
+  = Vr Ident           -- i.e. variables: x,y,z ...
+  | Cn Ident           -- i.e. constructors: cons, nil, etc.
+  | App Term Term      -- i.e. function application: @f x@
+  | Abs Ident Term     -- i.e. \x -> t
+  | FV [Term]          -- i.e. a list of variants: t1|t2|t3|...
+
+type Env s = [(Ident,Thunk s)]
+data Value s
+  = VApp Ident [Thunk s]   -- i.e. constructor application
+  | VClosure (Env s) Term  -- i.e. a closure contains an environment and the term for a lambda abstraction
+  | VGen Int [Thunk s]     -- i.e. an internal representation for free variables
+```
+The eval/apply rules are similar 
+```Haskell
+eval env (Vr x)          args = do tnk <- lookup x env
+                                   v   <- force tnk
+                                   apply v args
+eval env (Cn c)          args = return (VApp c args)
+eval env (App t1 t2)     args = do tnk <- newThunk env t2
+                                   eval env t1 (tnk : args)
+eval env (Abs x t)         [] = return (VClosure env (Abs x t))
+eval env (Abs x t) (arg:args) = eval ((x,arg):env) t args
+eval env (FV ts)         args = msum [eval env t args | t <- ts]
+
+apply (VApp f  vs)                   args = return (VApp f (vs++args))
+apply (VClosure env (Abs x t)) (arg:args) = eval ((x,arg):env) t args
+apply (VGen i  vs)                   args = return (VGen i (vs++args))
+```
+
+```Haskell
+value2term i (VApp c tnks) =
+  foldM (\t tnk -> fmap (App t) (force tnk >>= value2term i)) (Cn c) tnks
+value2term i (VGen j tnks) =
+  foldM (\t tnk -> fmap (App t) (force tnk >>= value2term i)) (Vr ('v':show j)) tnks
+value2term i (VClosure env (Abs x t)) = do
+  tnk <- newEvaluatedThunk (VGen i [])
+  v <- eval ((x,tnk):env) t []
+  t <- value2term (i+1) v
+  return (Abs ('v':show i) t)
+
+normalForm gr t =
+  case runEvalM gr (eval [] t [] >>= value2term 0) of
+    [t] -> t
+    ts  -> FV ts
+```
+
+# Meta Variables

doc/hackers-guide/README.md

@@ -0,0 +1,20 @@
+# The Hacker's Guide to GF
+
+This is the hacker's guide to GF, for the guide to the galaxy, see the full edition [here](https://en.wikipedia.org/wiki/The_Hitchhiker%27s_Guide_to_the_Galaxy).
+Here we will limit outselves to the vastly narrower domain of the [GF](https://www.grammaticalframework.org) runtime. This means that we will not meet
+any [Vogons](https://en.wikipedia.org/wiki/Vogon), but we will touch upon topics like memory management, databases, transactions, compilers,
+functional programming, theorem proving and sometimes even languages. Subjects that no doubt would interest any curious hacker.
+
+So, **Don't Panic!** and keep reading. This is a live document and will develop together with the runtime itself.
+
+**TABLE OF CONTENTS**
+
+1. Compilation
+   1. [Overview](CompilationOverview.md)
+   1. [Lambda Calculus](LambdaCalculus.md)
+   2. [Parallel Multiple Context-Free Grammars](PMCFG.md)
+2. Runtime
+   1. [Desiderata](DESIDERATA.md)
+   2. [Memory Model](memory_model.md)
+   3. [Abstract Expressions](abstract_expressions.md)
+   4. [Transactions](transactions.md)

doc/hackers-guide/abstract_expressions.md

@@ -0,0 +1,192 @@
+# Data Marshalling Strategies
+
+The runtime is designed to be used from a high-level programming language, which means that there are frequent foreign calls between the host language and C. This also implies that all the data must be frequently marshalled between the binary representations of the two languages. This is usually trivial and well supported for primitive types like numbers and strings but for complex data structures we need to design our own strategy.
+
+The most central data structure in GF is of course the abstract syntax expression. The other two secondary but closely related structures are types and literals. These are complex structures and no high-level programming language will let us to manipulate them directly unless if they are in the format that the runtime of the language understands. There are three main strategies to deal with complex data accross a language boundry:
+
+1. Keep the data in the C world and provide only an opaque handle to the host language. This means that all operations over the data must be done in C via foreign calls.
+2. Design a native host-language representation. For each foreign call the data is copied from the host language to the C representation and vice versa. Copying is obviously bad, but not too bad if the data is small. The added benefit is that now both languages have first-class access to the data. As a bonus, the garbage collector of the host language now understands the data and can immediately release it if part of it becomes unreachable.
+3. Keep the data in the host language. The C code has only an indirect access via opaque handles and calls back to the host language. The program in the host language has first-class access and the garbage collector can work with the data. No copying is needed.
+
+The old C runtime used option 1. Obviously, this means that abstract expressions cannot be manipulated directly, but this is not the only problem. When the application constructs abstract expressions from different pieces, a whole a lot of overhead is added. First, the design was such that data in C must always be allocated from a memory pool. This means that even if we want to make a simple function application, we first must allocate a pool which adds memory overhead. In addition, the host language must allocate an object which wraps arround the C structure. The net effect is that while the plain abstract function application requires the allocation of only two pointers, the actually allocated data may be several times bigger if the application builds the expression piece by piece. The situation is better if the expression is entirely created from the runtime and the application just needs to keep a reference to it.
+
+Another problem is that when the runtime has to create a whole bunch of expressions, for instance as a result from parsing or random and exhaustive generation, then all the expressions are allocated in the same memory pool. The application gets separate handles to each of the produced expressions, but the memory pool is released only after all of the handles become unreachable. Obviously the problem here is that different expressions share the same pool. Unfortunately this is hard to avoid since although the expressions are different, they usually share common subexpression. Identifying the shared parts would be expensive and at the end it might mean that each expression node must be allocated in its own pool.
+
+The path taken in the new runtime is a combination of strategies 2 and 3. The abstract expressions are stored in the heap of the host language and use a native for that language representation.
+
+# Abstract Expressions in Different Languages
+
+In Haskell, abstract expressions are represented with an algebraic data type:
+```Haskell
+data Expr =
+   EAbs BindType Var Expr
+ | EApp Expr Expr
+ | ELit Literal
+ | EMeta  MetaId
+ | EFun   Fun
+ | EVar   Int
+ | ETyped Expr Type
+ | EImplArg Expr
+```
+while in Python and all other object-oriented languages an expression is represented with objects of different classes:
+```Python
+class Expr: pass
+class ExprAbs(Expr): pass
+class ExprApp(Expr): pass
+class ExprLit(Expr): pass
+class ExprMeta(Expr): pass
+class ExprFun(Expr): pass
+class ExprVar(Expr): pass
+class ExprTyped(Expr): pass
+class ExprImplArg(Expr): pass
+```
+
+The runtime needs its own representation as well but only when an expression is stored in a .ngf file. This happens for instance with all types in the abstract syntax of the grammar. Since the type system allows dependent types, some type signature might contain expressions too. Another appearance for abstract expressions is in function definitions, i.e. in the def rules.
+
+Expressions in the runtime are represented with C structures which on the other hand may contain tagged references to other structures. The lowest four bits of each reference encode the type of structure that it points to, while the rest contain the file offsets in the memory mapped file. For example, function application is represented as:
+```C++
+struct PgfExprApp {
+  static const uint8_t tag = 1;
+
+  PgfExpr fun;
+  PgfExpr arg;
+};
+```
+Here the constant `tag` says that any reference to a PgfExprApp structure must contain the value 1 in its lowest four bits. The fields `fun` and `arg` refer to the function and the argument for that application. The type PgfExpr is defined as:
+```C++
+typedef uintptr_t object;
+typedef object PgfExpr;
+```
+In order to dereference an expression, we first neeed to pattern match and then obtain a `ref<>` object:
+```C++
+switch (ref<PgfExpr>::get_tag(e)) {
+...
+case PgfExprApp::tag: {
+    auto eapp = ref<PgfExprApp>::untagged(e);
+    // do something with eapp->fun and eapp->arg
+    ...
+    break;
+}
+...
+}
+```
+
+The representation in the runtime is internal and should never be exposed to the host language. Moreover, these structures live in the memory mapped file and as we discussed in Section "[Memory Model](memory_model.md)" accessing them requires special care. This also means that occasionally the runtime must make a copy from the native representation to the host representation and vice versa. For example, function:
+```Haskell
+functionType :: PGF -> Fun -> Maybe Type
+```
+must look up the type of an abstract syntax function in the .ngf file and return its type. The type, however, is in the native representation and it must first be copied in the host representation. The converse also happens. When the compiler wants to add a new abstract function to the grammar, it creates its type in the Haskell heap, which the runtime later copies to the native representation in the .ngf file. This is not much different from any other database. The database file usually uses a different data representation than what the host language has.
+
+In most other runtime operations, copying is not necessary. The only thing that the runtime needs to know is how to create new expressions in the heap of the host and how to pattern match on them. For that it calls back to code implemented differently for each host language. For example in:
+```Haskell
+readExpr :: String -> Maybe Expr
+```
+the runtime knows how to read an abstract syntax expression, while for the construction of the actual value it calls back to Haskell. Similarly:
+```Haskell
+showExpr :: [Var] -> Expr -> String
+```
+uses code implemented in Haskell to pattern match on the different algebraic constructors, while the text generation itself happens inside the runtime.
+
+# Marshaller and Unmarshaller
+
+The marshaller and the unmarshaller are the two key data structures which bridge together the different representation realms for abstract expressions and types. The structures have two equivalent definitions, one in C++:
+```C++
+struct PgfMarshaller {
+    virtual object match_lit(PgfUnmarshaller *u, PgfLiteral lit)=0;
+    virtual object match_expr(PgfUnmarshaller *u, PgfExpr expr)=0;
+    virtual object match_type(PgfUnmarshaller *u, PgfType ty)=0;
+};
+
+struct PgfUnmarshaller {
+    virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body)=0;
+    virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg)=0;
+    virtual PgfExpr elit(PgfLiteral lit)=0;
+    virtual PgfExpr emeta(PgfMetaId meta)=0;
+    virtual PgfExpr efun(PgfText *name)=0;
+    virtual PgfExpr evar(int index)=0;
+    virtual PgfExpr etyped(PgfExpr expr, PgfType typ)=0;
+    virtual PgfExpr eimplarg(PgfExpr expr)=0;
+    virtual PgfLiteral lint(size_t size, uintmax_t *v)=0;
+    virtual PgfLiteral lflt(double v)=0;
+    virtual PgfLiteral lstr(PgfText *v)=0;
+    virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
+                         PgfText *cat,
+                         int n_exprs, PgfExpr *exprs)=0;
+    virtual void free_ref(object x)=0;
+};
+```
+and one in C:
+```C
+typedef struct PgfMarshaller PgfMarshaller;
+typedef struct PgfMarshallerVtbl PgfMarshallerVtbl;
+struct PgfMarshallerVtbl {
+    object (*match_lit)(PgfUnmarshaller *u, PgfLiteral lit);
+    object (*match_expr)(PgfUnmarshaller *u, PgfExpr expr);
+    object (*match_type)(PgfUnmarshaller *u, PgfType ty);
+};
+struct PgfMarshaller {
+    PgfMarshallerVtbl *vtbl;
+};
+
+typedef struct PgfUnmarshaller PgfUnmarshaller;
+typedef struct PgfUnmarshallerVtbl PgfUnmarshallerVtbl;
+struct PgfUnmarshallerVtbl {
+    PgfExpr (*eabs)(PgfUnmarshaller *this, PgfBindType btype, PgfText *name, PgfExpr body);
+    PgfExpr (*eapp)(PgfUnmarshaller *this, PgfExpr fun, PgfExpr arg);
+    PgfExpr (*elit)(PgfUnmarshaller *this, PgfLiteral lit);
+    PgfExpr (*emeta)(PgfUnmarshaller *this, PgfMetaId meta);
+    PgfExpr (*efun)(PgfUnmarshaller *this, PgfText *name);
+    PgfExpr (*evar)(PgfUnmarshaller *this, int index);
+    PgfExpr (*etyped)(PgfUnmarshaller *this, PgfExpr expr, PgfType typ);
+    PgfExpr (*eimplarg)(PgfUnmarshaller *this, PgfExpr expr);
+    PgfLiteral (*lint)(PgfUnmarshaller *this, size_t size, uintmax_t *v);
+    PgfLiteral (*lflt)(PgfUnmarshaller *this, double v);
+    PgfLiteral (*lstr)(PgfUnmarshaller *this, PgfText *v);
+    PgfType (*dtyp)(PgfUnmarshaller *this,
+                    int n_hypos, PgfTypeHypo *hypos,
+                    PgfText *cat,
+                    int n_exprs, PgfExpr *exprs);
+    void (*free_ref)(PgfUnmarshaller *this, object x);
+};
+struct PgfUnmarshaller {
+    PgfUnmarshallerVtbl *vtbl;
+};
+```
+Which one you will get, depends on whether you import `pgf/pgf.h` from C or C++.
+
+As we can see, most of the arguments for the different methods are of type `PgfExpr`, `PgfType` or `PgfLiteral`. These are all just type synonyms for the type `object`, which on the other hand is nothing else but a number with enough bits to hold an address if necessary. The interpretation of the number depends on the realm in which the object lives. The following table shows the interpretations for four languages as well as the one used internally in the .ngf files:
+|          | PgfExpr        | PgfLiteral        | PgfType        |
+|----------|----------------|-------------------|----------------|
+| Haskell  | StablePtr Expr | StablePtr Literal | StablePtr Type |
+| Python   | ExprObject *   | PyObject *        | TypeObject *   |
+| Java     | jobject        | jobject           | jobject        |
+| .NET     | GCHandle       | GCHandle          | GCHandle       |
+| internal | file offset    | file offset       | file offset    |
+
+The marshaller is the structure that lets the runtime to pattern match on an expression. When one of the match methods is executed, it checks the kind of expr, literal or type and calls the corresponding method from the unmarshaller which it gets as an argument. The method on the other hand gets as arguments the corresponding sub-expressions and attributes.
+
+Generally the role of an unmarshaller is to construct things. For example, the variable `unmarshaller` in `PGF2.FFI` is an object which can construct new expressions in the Haskell heap from the already created children. Function `readExpr`, for instance, passes that one to the runtime to instruct it that the result must be in the Haskell realm.
+
+Constructing objects is not the only use of an unmarshaller. The implementation of `showExpr` passes to `pgf_print_expr` an abstract expression in Haskell and the `marshaller` defined in PGF2.FFI. That marshaller knows how to pattern match on Haskell expressions and calls the right methods from whatever unmarhaller is given to it. What it will get in that particular case is a special unmarshaller which does not produce new representations of abstract expressions, but generates a string.
+
+
+# Literals
+
+Finally, we should have a few remarks about how values of the literal types `String`, `Int` and `Float` are represented in the runtime.
+
+`String` is represented as the structure:
+```C
+typedef struct {
+    size_t size;
+    char text[];
+} PgfText;
+```
+Here the first field is the size of the string in number of bytes. The second field is the string itself, encoded in UTF-8. Just like in most modern languages, the string may contain the zero character and that is not an indication for end of string. This means that functions like `strlen` and `strcat` should never be used when working with PgfText. Despite that the text is not zero terminated, the runtime always allocates one more last byte for the text content and sets it to zero. That last byte is not included when calculating the field `size`. The purpose is that with that last zero byte the GDB debugger knows how to show the string properly. Most of the time, this doesn't incur any memory overhead either since `malloc` always allocates memory in size divisible by the size of two machine words. The consequence is that usually there are some byte left unused at the end of every string anyway.
+
+`Int` is like the integers in Haskell and Python and can have arbitrarily many digits. In the runtime, the value is represented as an array of `uintmax_t` values. Each of these values contains as many decimal digits as it is possible to fit in `uintmax_t`. For example on a 64-bit machine, 
+the maximal value that fits is 18446744073709551616. However, the left-most digit here is at most 1, this means that if we want to represend an arbitrary sequence of digits, the maximal length of the sequence must be at most 19. Similarly on a 32-bit machine each value in the array will store 9 decimal digits. Finally the sign of the number is stored as the sign of the first number in the array which is always threated as `intmax_t`.
+
+Just to have an example, the number `-774763251095801167872` is represented as the array `{-77, 4763251095801167872}`. Note that this representation is not at all suitable for implementing arithmetics with integers, but is very simple to use for us since the runtime only needs to to parse and linearize numbers.
+
+`Float` is trivial and is just represented as the type `double` in C/C++. This can also be seen in the type of the method `lflt` in the unmarshaller.
+

doc/hackers-guide/memory_model.md

@@ -0,0 +1,136 @@
+# The different storage files
+
+The purpose of the `.ngf` files is to be used as on-disk databases that store grammars. Their format is platform-dependent and they should not be copied from
+one platform to another. In contrast the `.pgf` files are platform-independent and can be moved around. The runtime can import a `.pgf` file and create an `.ngf` file.
+Conversely a `.pgf` file can be exported from an already existing `.ngf` file.
+
+The internal relation between the two files is more interesting. The runtime uses its own memory allocator which always allocates memory from a memory mapped file.
+The file may be explicit or an anonymous one. The `.ngf` is simply a memory image saved in a file. This means that loading the file is always immediate.
+You just create a new mapping and the kernel will load memory pages on demand.
+
+On the other hand a `.pgf` file is a version of the grammar serialized in a platform-independent format. This means that loading this type of file is always slower.
+Fortunately, you can always create an `.ngf` file from it to speed up later reloads.
+
+The runtime has three ways to load a grammar:
+
+#### 1. Loading a `.pgf`
+```Haskell
+readPGF :: FilePath -> IO PGF
+```
+This loads the `.pgf` into an anonymous memory-mapped file. In practice, this means that instead of allocating memory from an explicit file, the runtime will still
+use the normal swap file.
+
+#### 2. Loading a `.pgf` and booting a new `.ngf`
+```Haskell
+bootPGF :: FilePath -> FilePath -> IO PGF
+```
+The grammar is loaded from a `.pgf` (the first argument) and the memory is mapped to an explicit `.ngf` (second argument). The `.ngf` file is created by the function
+and a file with the same name should not exist before the call.
+
+#### 3. Loading an existing memory image
+```Haskell
+readNGF :: FilePath -> IO PGF
+```
+Once an `.ngf` file exists, it can be mapped back to memory by using this function. This call is always guaranteed to be fast. The same function can also
+create new empty `.ngf` files. If the file does not exist, then a new one will be created which contains an empty grammar. The grammar could then be extended
+by dynamically adding functions and categories.
+
+# The content of an `.ngf` file
+
+The `.ngf` file is a memory image but this is not the end of the story. The problem is that there is no way to control at which address the memory image would be
+mapped. On Posix systems, `mmap` takes as hint the mapping address but the kernel may choose to ignore it. There is also the flag `MAP_FIXED`, which makes the hint
+into a constraint, but then the kernel may fail to satisfy the constraint. For example that address may already be used for something else. Furthermore, if the
+same file is mapped from several processes (if they all load the same grammar), it would be difficult to find an address which is free in all of them.
+Last but not least using `MAP_FIXED` is considered a security risk.
+
+Since the start address of the mapping can change, using traditional memory pointers withing the mapped area is not possible. The only option is to use offsets
+relative to the beginning of the area. In other words, if normally we would have written `p->x`, now we have the offset `o` which we must use like this:
+```C++
+((A*) (current_base+o))->x
+```
+
+Writing the explicit pointer arithmetics and typecasts, each time when we dereference a pointer, is not better than Vogon poetry and it
+becomes worse when using a chain of arrow operators. The solution is to use the operator overloading in C++.
+There is the type `ref<A>` which wraps around a file offset to a data item of type `A`. The operators `->` and `*`
+are overloaded for the type and they do the necessary pointer arithmetics and type casts.
+
+This solves the problem with code readability but creates another problem. How do `->` and `*` know the address of the memory mapped area? Obviously,
+`current_base` must be a global variable and there must be a way to initialize it. More specifically it must be thread-local to allow different threads to
+work without collisions.
+
+A database (a memory-mapped file) in the runtime is represented by the type `DB`. Before any of the data in the database is accessed, the database must
+be brought into scope. Bringing into scope means that `current_base` is initialized to point to the mapping area for that database. After that any dereferencing
+of a reference will be done relative to the corresponding database. This is how scopes are defined:
+```C++
+{
+    DB_scope scope(db, READER_SCOPE);
+    ...
+}
+```
+Here `DB_scope` is a helper type and `db` is a pointer to the database that you want to bring into scope. The constructor for `DB_scope` saves the old value
+for `current_base` and then sets it to point to the area of the given database. Conversely, the destructor restores the previous value.
+
+The use of `DB_scope` is reentrant, i.e. you can do this:
+```C++
+{
+    DB_scope scope(db1, READER_SCOPE);
+    ...
+    {
+        DB_scope scope(db2, READER_SCOPE);
+        ...
+    }
+    ...
+}
+```
+What you can't do is to have more than one database in scope simultaneously. Fortunately, that is not needed. All API functions start a scope
+and the internals of the runtime always work with the current database in scope.
+
+Note the flag `READER_SCOPE`. You can use either `READER_SCOPE` or `WRITER_SCOPE`. In addition to selecting the database, the `DB_scope` also enforces
+the single writer/multiple readers policy. The main problem is that a writer may have to enlarge the current file, which consequently may mean
+that the kernel should relocate the mapping area to a new address. If there are readers at the same time, they may break since they expect that the mapped
+area is at a particular location.
+
+# Developing writers
+
+There is one important complication when developing procedures modifying the database. Every call to `DB::malloc` may potentially have to enlarge the mapped area
+which sometimes leads to changing `current_base`. That would not have been a problem if GCC was not sometimes caching variables in registers. Look at the following code:
+```C++
+p->r = foo();
+```
+Here `p` is a reference which is used to access another reference `r`. On the other hand, `foo()` is a procedure which directly or indirectly calls `DB::malloc`.
+GCC compiles assignments by first computing the address to modify, and then it evaluates the right hand side. This means that while `foo()` is being evaluated the address computed on the left-hand side is saved in a register or somewhere in the stack. But now, if it happens that the allocation in `foo()` has changed
+`current_base`, then the saved address is no longer valid.
+
+That first problem is solved by overloading the assignment operator for `ref<A>`:
+```C++
+ref<A>& operator= (const ref<A>& r) {
+    offset = r.offset;
+    return *this;
+}
+```
+On first sight, nothing special happens here and it looks like the overloading is redundant. However, now the assignments are compiled in a very different way.
+The overloaded operator is inlined, so there is no real method call and we don't get any overhead. The real difference is that now, whatever is on the left-hand side of the assignment becomes the value of the `this` pointer, and `this` is always the last thing to be evaluated in a method call. This solves the problem.
+`foo()` is evaluated first and if it changes `current_base`, the change will be taken into account when computing the left-hand side of the assignment.
+
+Unfortunately, this is not the only problem. A similar thing happens when the arguments of a function are calls to other functions. See this:
+```C++
+foo(p->r,bar(),q->r)
+```
+Where now `bar()` is the function that performs allocation. The compiler is free to keep in a register the value of `current_base` that it needs for the evaluation of
+`p->r`, while it evaluates `bar()`. But if `current_base` has changed, then the saved value would be invalid while computing `q->r`. There doesn't seem to be
+a work around for this. The only solution is to:
+
+**Never call a function that allocates as an argument to another function**
+
+Instead we call allocating functions on a separate line and we save the result in a temporary variable.
+
+
+# Thread-local variables
+
+A final remark is the compilation of thread-local variables. When a thread-local variable is compiled in a position-dependent code, i.e. in executables, it is
+compiled efficiently by using the `fs` register which points to the thread-local segment. Unfortunately, that is not the case by default for shared
+libraries like our runtime. In that case, GCC applies the global-dynamic model which means that access to a thread local variable is internally implemented
+with a call to the function `__tls_get_addr`. Since `current_base` is used all the time, this adds overhead.
+
+The solution is to define the variable with the attribute `__attribute__((tls_model("initial-exec")))` which says that it should be treated as if it is defined
+in an executable. This removes the overhead, but adds the limitation that the runtime should not be loaded with `dlopen`.

doc/hackers-guide/transactions.md

@@ -0,0 +1,137 @@
+# Transactions
+
+The `.ngf` files that the runtime creates are actual databases which are used to get quick access to the grammars. Like in any database, we also make it possible to dynamically change the data. In our case this means that we can add and remove functions and categories at any time. Moreover, any changes happen in transactions which ensure that changes are not visible until the transaction is commited. The rest of the document describes how the transactions are implemented.
+
+# Databases and Functional Languages
+
+The database model of the runtime is specifically designed to be friendly towards pure functional languages like Haskell. In a usual database, updates happen constantly and therefore executing one and the same query at different times would yield different results. In our grammar databases, queries correspond to operations like parsing, linearization and generation. This means that if we had used the usual database model, all these operations would have to be bound to the IO monad. Consider this example:
+```Haskell
+main = do
+  gr <- readNGF "Example.ngf"
+  functionType gr "f" >>= print
+  -- modify the grammar gr
+  functionType gr "f" >>= print
+```
+Here we ask for the type of a function before and after an arbitrary update in the grammar `gr`. Obviously if we allow that, then `functionType` would have to be in the IO monad, e.g.:
+
+```Haskell
+functionType :: PGF -> Fun -> IO Type
+```
+
+Although this is a possible way to go, it would mean that the programmer would have to do all grammar related work in the IO. This is not nice and against the spirit of functional programming. Moreover, all previous implementations of the runtime have assumed that most operations are pure. If we go along that path then this will cause a major breaking change.
+
+Fortunately there is an alternative. Read-only operations remain pure functions, but any update should create a new revision of the database rather than modifying the existing one. Compare this example with the previous:
+```Haskell
+main = do
+  gr <- readNGF "Example.ngf"
+  print (functionType gr "f")
+  gr2 <- modifyPGF gr $ do
+           -- do all updates here
+  print (functionType gr2 "f")
+```
+Here `modifyPGF` allows us to do updates but the updates are performed on a freshly created clone of the grammar `gr`. The original grammar is never ever modified. After the changes the variable `gr2` is a reference to the new revision. While the transaction is in progress we cannot see the currently changing revision, and therefore all read-only operations can remain pure. Only after the transaction is complete, do we get to use `gr2`, which will not allowed to change anymore.
+
+Note also that above `functionType` is used with its usual pure type:
+```Haskell
+functionType :: PGF -> Fun -> Type
+```
+This is safe since the API never exposes database revisions which are not complete. Furthermore, the programmer is free to keep several revisions of the same database simultaneously. In this example:
+```Haskell
+main = do
+  gr <- readNGF "Example.ngf"
+  gr2 <- modifyPGF gr $ do
+           -- do all updates here
+  print (functionType gr "f", functionType gr2 "f")
+```
+The last line prints the type of function `"f"` in both the old and the new revision. Both are still available.
+
+The API as described so far would have been complete if all updates were happening in a single thread. In reality we can expect that there might be several threads or processes modifying the database. The database ensures a multiple readers/single writer exclusion but this doesn't mean that another process/thread cannot modify the database while the current one is reading an old revision. In a parallel setting, `modifyPGF` first merges the revision which the process is using with the latest revision in the database. On top of that the specified updates are performed. The final revision after the updates is returned as a result.
+
+**TODO: Merges are still not implemented.**
+
+The process can also ask for the latest revision by calling `checkoutPGF`, see bellow.
+
+# Databases and Imperative Languages
+
+In imperative languages, the state of the program constantly changes and the considerations in the last section do not apply. All read-only operations always work with the latest revision. Bellow is the previous example translated to Python:
+```Python
+gr = readNGF("Example.ngf")
+print(functionType(gr,"f"))
+with gr.transaction() as t:
+  # do all updates here by using t
+print(functionType(gr,"f"))
+```
+Here the first call to `functionType` returns the old type of "f", while the second call retrives the type after the updates. The transaction itself is initiated by the `with` statement. Inside the with statement `gr` will still refer to the old revision since the new one is not complete yet. If the `with` statement is finished without exceptions then `gr` is updated to point to the new one. If an exception occurs then the new revision is discarded, which corresponds to a transaction rollback. Inside the `with` block, the object `t` of type `Transaction` provides methods for modifying the data.
+
+# Branches
+
+Since the database already supports revisions, it is a simple step to support branches as well. A branch is just a revision with a name. When you open a database with `readNGF`, the runtime looks up and returns the revision (branch) with name `master`. There might be other branches as well. You can retrieve a specific branch by calling:
+```Haskell
+checkoutPGF :: PGF -> String -> IO (Maybe PGF)
+```
+Here the string is the branch name. New branches can be created by using:
+```Haskell
+branchPGF :: PGF -> String -> Transaction a -> IO PGF
+```
+Here we start with an existing revision, apply a transaction and store the result in a new branch with the given name.
+
+# Implementation
+
+In this section we summarize important design decisions related to the internal implementation.
+
+## API
+The low-level API for transactions consists of only four functions:
+```C
+PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
+                               PgfText *name,
+                               PgfExn *err);
+
+void pgf_free_revision(PgfDB *pgf, PgfRevision revision);
+
+void pgf_commit_revision(PgfDB *db, PgfRevision revision,
+                         PgfExn *err);
+
+PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name,
+                                  PgfExn *err);
+```
+Here `pgf_clone_revision` makes a copy of an existing revision and — if `name` is not `NULL` — changes its name. The new revision is transient and exists only until it is released with `pgf_free_revision`. Transient revisions can be updated with the API for adding functions and categories. To make a revision persistent, call `pgf_commit_revision`. After the revision is made persistent it will stay in the database even after you call `pgf_free_revision`. Moreover, it will replace the last persistent revision with the same name. The old revision will then become transient and will exist only until all clients call `pgf_free_revision` for it.
+
+Persistent revisions can never be updated. Instead you clone it to create a new transient revision. That one is updated and finally it replaces the existing persistent revision.
+
+This design for transactions may sound unusual but it is just another way to present the copy-on-write strategy. There instead of transaction logs, each change to the data is written in a new place and the result is made available only after all changes are in place. This is for instance what the [LMDB](http://www.lmdb.tech/doc/) (Lightning Memory-Mapped Database) does and it has also served as an inspiration for us.
+
+## Functional Data Structures
+
+From an imperative point of view, it may sound wasteful that a new copy of the grammar is created for each transaction. Functional programmers on the other hand know that with a functional data structure, you can make a copy which shares as much of the data with the original as possible. Each new version copies only those bits that are different from the old one. For example the main data structure that we use to represent the abstract syntax of a grammar is a size-balanced binary tree as described by:
+
+- Stephen Adams, "Efficient sets: a balancing act", Journal of Functional Programming 3(4):553-562, October 1993, http://www.swiss.ai.mit.edu/~adams/BB/.
+
+- J. Nievergelt and E.M. Reingold, "Binary search trees of bounded balance", SIAM journal of computing 2(1), March 1973.
+
+This is also the same algorithm used by Data.Map in Haskell. There are also other possible implementations (B-Trees for instance), and they may be considered if the current one turns our too inefficient.
+
+
+## Garbage Collection
+
+We use reference counting to keep track of which objects should be kept alive. For instance, `pgf_free_revision` knows that a transient revision should be removed only when its reference count reaches zero. This means that there is no process or thread using it. The function also checks whether the revision is persistent. Persistent revisions are never removed since they can always be retrieved with `checkoutPGF`.
+
+Clients are supposed to correctly use `pgf_free_revision` to indicate that they don't need a revision any more. Unfortunately, this is not always possible to guarantee. For example many languages with garbage collection call `pgf_free_revision` from a finalizer method. In some languages, however, the finalizer is not guaranteed to be executed if the process terminates before the garbage collection is done. Haskell is one of those languages. Even in languages with reference counting like Python, the process may get killed by the operating system and then the finalizer may still not be executed.
+
+The solution is that we count on the database clients to correctly report when a revision is not needed. In addition, to be on the safe side, on a fresh database restart we explictly clean all leftover transient revisions. This means that even if a client is killed or if it does not correctly release its revisions, the worst that can happen is a memory leak until the next restart. Here by fresh restart we mean a situation where a process opens a database which is not used by anyone else. In order to detect that case we maintain a list of processes who currently have access to the file. While a new process is added, we also remove all processes in the list who are not alive anymore. If at the end the list contains only one element, then this is a fresh restart.
+
+## Inter-process Communication
+
+One and the same database may be opened by several processes. In that case, each process creates a mapping of the database into his own address space. The mapping is shared, which means that if a page from the database gets loaded in memory, it is loaded in a single place in the physical memory. The physical memory is then assigned possibly different virtual addresses in each process. All processes can read the data simultaneously, but if we let them to change it at the same time, all kinds of problems may happen. To avoid that, we store a single-writer/multiple-readers lock in the database file, which the processes use for synchronization.
+
+## Atomicity
+
+The transactions serve two goals. First they make it possible to isolate readers from seeing unfinished changes from writers. Second, they ensure atomicity. A database change should be either completely done or not done at all. The use of transient revisions ensures the isolation but the atomicity is only partly taken care of.
+
+Think about what happens when a writer starts updating a transient revision. All the data is allocated in a memory mapped file. From the point of view of the runtime, all changes happen in memory. When all is done, the runtime calls `msync` which tells the kernel to flush all dirty pages to disk. The problem is that the kernel is also free to flush pages at any time. For instance, if there is not enough memory, it may decide to swap out pages earlier and reuse the released physical space to swap in other virtual pages. This would be fine if the transaction eventually succeeds. However, if this doesn't happen then the image in the file is already changed.
+
+We can avoid the situation by calling [mlock](https://man7.org/linux/man-pages/man2/mlock.2.html) and telling the kernel that certain pages should not be swapped out. The question is which pages to lock. We can lock them all, but this is too much. That would mean that as soon as a page is touched it will never leave the physical memory. Instead, it would have been nice to tell the kernel -- feel free to swap out clean pages but, as soon as they get dirty, keep them in memory until further notice. Unfortunately there is no way to do that directly.
+
+The work around is to first use [mprotect](https://man7.org/linux/man-pages/man2/mprotect.2.html) and keep all pages as read-only. Any attempt to change a page will cause segmentation fault which we can capture. If the change happens during a transaction then we can immediate lock the page and add it to the list of modified pages. When a transaction is successful we sync all modified pages. If an attempt to change a page happens outside of a transaction, then this is either a bug in the runtime or the client is trying to change an address which it should not change. In any case this prevents unintended changes in the data.
+
+
+**TODO: atomicity is not implemented yet**

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 5; the depth can be
+The default **depth** is 3; the depth can be
 set by using the ``depth`` flag:
 ```
   > generate_trees -depth=2 | l
@@ -1265,16 +1265,10 @@ 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.
-
-This works on Mac OS X:
+telling what command to use to view the file. Its default is ``"open"``, which works
+on Mac OS X. On Ubuntu Linux, one can write
 ```
-  > 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
+  > parse "this delicious cheese is very Italian" | visualize_tree -view="eog"
 ```
 
 
@@ -1739,13 +1733,6 @@ 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:
 ```
@@ -3746,7 +3733,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
@@ -4184,7 +4171,7 @@ division of integers.
 ```
   abstract Calculator = {
   flags startcat = Exp ;
-
+  
   cat Exp ;
 
   fun
@@ -4591,7 +4578,7 @@ in any multilingual grammar between any languages in the grammar.
 module Main where
 
 import PGF
-import System.Environment (getArgs)
+import System (getArgs)
 
 main :: IO ()
 main = do

download/index-3.11.md

@@ -139,8 +139,6 @@ stack install
 For more info on working with the GF source code, see the
 [GF Developers Guide](../doc/gf-developers.html).
 
-For macOS Sequoia, you need to downgrade the LLVM package, see instructions [here](https://github.com/GrammaticalFramework/gf-core/issues/172#issuecomment-2599365457).
-
 ## Installing the Python bindings from PyPI
 
 The Python library is available on PyPI as `pgf`, so it can be installed using:

download/index-3.12.md

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

download/index.html

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

download/release-3.12.md

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

flake.lock

@@ -1,43 +0,0 @@
-{
-  "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

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

gf-book/examples/chapter2/FoodIta.gf

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

gf-book/examples/chapter3/ResIta.gf

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

gf-book/examples/chapter5/LexFoodsFin.gf

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

gf-book/examples/chapter5/LexFoodsGer.gf

@@ -1,16 +1,16 @@
 -- (c) 2009 Aarne Ranta under LGPL
 
-instance LexFoodsGer of LexFoods =
+instance LexFoodsGer of LexFoods = 
     open SyntaxGer, ParadigmsGer in {
   oper
     wine_N = mkN "Wein" ;
     pizza_N = mkN "Pizza" "Pizzen" feminine ;
-    cheese_N = mkN "Käse" "Käse" masculine ;
+    cheese_N = mkN "Käse" "Käse" masculine ;
     fish_N = mkN "Fisch" ;
     fresh_A = mkA "frisch" ;
-    warm_A = mkA "warm" "wärmer" "wärmste" ;
+    warm_A = mkA "warm" "wärmer" "wärmste" ;
     italian_A = mkA "italienisch" ;
     expensive_A = mkA "teuer" ;
-    delicious_A = mkA "köstlich" ;
+    delicious_A = mkA "köstlich" ;
     boring_A = mkA "langweilig" ;
 }

gf-book/examples/chapter5/LexFoodsSwe.gf

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

gf-book/examples/chapter7/QueryFin.gf

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

gf-book/examples/chapter9/ResIta.gf

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

index.html

@@ -57,6 +57,7 @@
       <li><a href="doc/gf-shell-reference.html">Shell Reference</a></li>
       <li><a href="http://www.molto-project.eu/sites/default/files/MOLTO_D2.3.pdf">Best Practices</a> <small>[PDF]</small></li>
       <li><a href="https://www.mitpressjournals.org/doi/pdf/10.1162/COLI_a_00378">Scaling Up (Computational Linguistics 2020)</a></li>
+      <li><a href="https://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>
 
@@ -87,6 +88,11 @@
     <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
@@ -100,7 +106,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/">Summer School</a></li>
+      <li><a href="//school.grammaticalframework.org/2020/">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">
@@ -227,9 +233,13 @@ least one, it may help you to get a first idea of what GF is.
     </p>
 
     <p>
-    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.
+    We run the IRC channel <strong><code>#gf</code></strong> on the Libera network, where you are welcome to look for help with small questions or just start a general discussion.
+    You can <a href="https://web.libera.chat/?channels=#gf">open a web chat</a>
+    or <a href="https://www.grammaticalframework.org/irc/?C=M;O=D">browse the channel logs</a>.
+    </p>
+    <p>
+    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
@@ -245,19 +255,6 @@ 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>
@@ -267,6 +264,10 @@ 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

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

nix/revert-new-cabal-madness.patch

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

src/compiler/GF.hs

@@ -1,42 +0,0 @@
--- | GF, the Grammatical Framework, as a library
-module GF(
-           -- * Command line interface
-           module GF.Main,
-           module GF.Interactive,
-           module GF.Compiler,
-
-           -- * Compiling GF grammars
-           module GF.Compile,
-           module GF.CompileInParallel,
---         module PF.Compile.Export, -- haddock does the wrong thing with this
-           exportPGF,
-           module GF.CompileOne,
-
-           -- * Abstract syntax, parsing, pretty printing and serialisation
-           module GF.Compile.GetGrammar,
-           module GF.Grammar.Grammar,
-           module GF.Grammar.Macros,
-           module GF.Grammar.Printer,
-           module GF.Infra.Ident,
-           -- ** Binary serialisation
-           module GF.Grammar.Binary,
-           -- * Canonical GF
-           module GF.Compile.GrammarToCanonical
-  ) where
-import GF.Main
-import GF.Compiler
-import GF.Interactive
-
-import GF.Compile
-import GF.CompileInParallel
-import GF.CompileOne
-import GF.Compile.Export(exportPGF)
-
-import GF.Compile.GetGrammar
-import GF.Grammar.Grammar
-import GF.Grammar.Macros
-import GF.Grammar.Printer
-import GF.Infra.Ident
-import GF.Grammar.Binary
-
-import GF.Compile.GrammarToCanonical

src/compiler/GF/Command/Commands2.hs

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

src/compiler/GF/Command/Importing.hs

@@ -1,62 +0,0 @@
-module GF.Command.Importing (importGrammar, importSource) where
-
-import PGF
-import PGF.Internal(optimizePGF,unionPGF,msgUnionPGF)
-
-import GF.Compile
-import GF.Compile.Multi (readMulti)
-import GF.Compile.GetGrammar (getBNFCRules, getEBNFRules)
-import GF.Grammar (SourceGrammar) -- for cc command
-import GF.Grammar.BNFC
-import GF.Grammar.EBNF
-import GF.Grammar.CFG
-import GF.Compile.CFGtoPGF
-import GF.Infra.UseIO(die,tryIOE)
-import GF.Infra.Option
-import GF.Data.ErrM
-
-import System.FilePath
-import qualified Data.Set as Set
-
--- import a grammar in an environment where it extends an existing grammar
-importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
-importGrammar pgf0 _ [] = return pgf0
-importGrammar pgf0 opts files =
-  case takeExtensions (last files) of
-    ".cf"   -> importCF opts files getBNFCRules bnfc2cf
-    ".ebnf" -> importCF opts files getEBNFRules ebnf2cf
-    ".gfm"  -> do
-      ascss <- mapM readMulti files
-      let cs = concatMap snd ascss
-      importGrammar pgf0 opts cs
-    s | elem s [".gf",".gfo"] -> do
-      res <- tryIOE $ compileToPGF opts files
-      case res of
-        Ok pgf2 -> ioUnionPGF pgf0 pgf2
-        Bad msg -> do putStrLn ('\n':'\n':msg)
-                      return pgf0
-    ".pgf" -> do
-      pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
-      ioUnionPGF pgf0 pgf2
-    ext -> die $ "Unknown filename extension: " ++ show ext
-
-ioUnionPGF :: PGF -> PGF -> IO PGF
-ioUnionPGF one two = case msgUnionPGF one two of
-  (pgf, Just msg) -> putStrLn msg >> return pgf
-  (pgf,_)         -> return pgf
-
-importSource :: Options -> [FilePath] -> IO SourceGrammar
-importSource opts files = fmap (snd.snd) (batchCompile opts files)
-
--- for different cf formats
-importCF opts files get convert = impCF
-  where
-    impCF = do
-      rules <- fmap (convert . concat) $ mapM (get opts) files
-      startCat <- case rules of
-                    (Rule cat _ _ : _) -> return cat
-                    _                  -> fail "empty CFG"
-      let pgf = cf2pgf (last files) (mkCFG startCat Set.empty rules)
-      probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf
-      return $ setProbabilities probs 
-             $ if flag optOptimizePGF opts then optimizePGF pgf else pgf

src/compiler/GF/Command/Parse.hs

@@ -1,72 +0,0 @@
-module GF.Command.Parse(readCommandLine, pCommand) where
-
-import PGF(pExpr,pIdent)
-import GF.Grammar.Parser(runPartial,pTerm)
-import GF.Command.Abstract
-
-import Data.Char(isDigit,isSpace)
-import Control.Monad(liftM2)
-import Text.ParserCombinators.ReadP
-
-readCommandLine :: String -> Maybe CommandLine
-readCommandLine s =
-    case [x | (x,cs) <- readP_to_S pCommandLine s, all isSpace cs] of
-      [x] -> Just x
-      _   -> Nothing
-
-pCommandLine =
-  (skipSpaces >> char '-' >> char '-' >> pTheRest >> return [])   -- comment
-  <++
-  (sepBy (skipSpaces >> pPipe) (skipSpaces >> char ';'))
-
-pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
-
-pCommand = (do
-  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
-  skipSpaces
-  opts <- sepBy pOption skipSpaces
-  arg  <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
-  return (Command cmd opts arg)
-  )
-    <++ (do
-  char '?'
-  skipSpaces
-  c <- pSystemCommand
-  return (Command "sp" [OFlag "command" (VStr c)] ANoArg)
-  )
-
-pOption = do
-  char '-'
-  flg <- pIdent
-  option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
-
-pValue = do
-  fmap VInt (readS_to_P reads)
-  <++
-  fmap VStr (readS_to_P reads)
-  <++
-  fmap VId  pFilename
-
-pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
-  isFileFirst c = not (isSpace c) && not (isDigit c)
-
-pArgument =
-  option ANoArg
-    (fmap AExpr pExpr
-              <++
-    (skipSpaces >> char '%' >> fmap AMacro pIdent))
-
-pArgTerm = ATerm `fmap` readS_to_P sTerm
-  where
-    sTerm s = case runPartial pTerm s of
-                Right (s,t) -> [(t,s)]
-                _ -> []
-
-pSystemCommand =
-    (char '"' >> (manyTill (pEsc <++ get) (char '"')))
-      <++
-    pTheRest
-  where
-    pEsc = char '\\' >> get
-
-pTheRest = munch (const True)

src/compiler/GF/Command/TreeOperations.hs

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

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -1,134 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-module GF.Compile.CFGtoPGF (cf2pgf) where
-
-import GF.Grammar.CFG
-import GF.Infra.UseIO
-
-import PGF
-import PGF.Internal
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
-import Data.Array.IArray
-import Data.List
-
---------------------------
--- the compiler ----------
---------------------------
-
-cf2pgf :: FilePath -> ParamCFG -> PGF
-cf2pgf fpath cf =
- let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
- in updateProductionIndices pgf
- where
-   name = justModuleName fpath
-   aname = mkCId (name ++ "Abs")
-   cname = mkCId name
-
-cf2abstr :: ParamCFG -> Abstr
-cf2abstr cfg = Abstr aflags afuns acats
-  where
-    aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
-
-    acats  = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
-                            | (cat,rules) <- (Map.toList . Map.fromListWith (++))
-                                                [(cat2id cat, catRules cfg cat) |
-                                                     cat <- allCats' cfg]]
-    afuns  = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
-                            | rule <- allRules cfg]
-
-    cat2id = mkCId . fst
-
-cf2concr :: ParamCFG -> Concr
-cf2concr cfg = Concr Map.empty Map.empty
-                     cncfuns lindefsrefs lindefsrefs
-                     sequences productions
-                     IntMap.empty Map.empty
-                     cnccats
-                     IntMap.empty
-                     totalCats
-  where
-    cats  = allCats' cfg
-    rules = allRules cfg
-
-    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
-                               map mkSequence rules)
-    sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
-
-    idFun = CncFun wildCId (listArray (0,0) [seqid])
-      where
-        seq   = listArray (0,0) [SymCat 0 0]
-        seqid = binSearch seq sequences (bounds sequences)
-    ((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
-    productions = foldl addProd IntMap.empty (concat (productions0++coercions))
-    cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
-
-    lbls = listArray (0,0) ["s"]
-    (fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
-                              [(c,p) | (c,ps) <- cats, p <- ps]
-    ((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
-    cnccats = Map.fromList cnccats0
-
-    lindefsrefs =
-       IntMap.fromList (map mkLinDefRef cats)
-
-    convertRule cs (funid,funs) rule =
-      let args   = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
-          prod   = PApply funid args
-          seqid  = binSearch (mkSequence rule) sequences (bounds sequences)
-          fun    = CncFun (mkRuleName rule) (listArray (0,0) [seqid])
-          funid' = funid+1
-      in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
-
-    mkSequence rule = listArray (0,length syms-1) syms
-      where
-        syms   = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
-
-        convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
-        convertSymbol d (Terminal t)        = (d,  SymKS t)
-
-    mkCncCat fid (cat,n)
-      | cat == "Int"    = (fid, (mkCId cat, CncCat fidInt    fidInt    lbls))
-      | cat == "Float"  = (fid, (mkCId cat, CncCat fidFloat  fidFloat  lbls))
-      | cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
-      | otherwise       = let fid' = fid+n+1
-                          in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
-
-    mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
-    mkCoercions (fid,cs) c@(cat,ps ) =
-      let fid' = fid+1
-      in fid' `seq` ((fid', Map.insert c fid cs), [(fid,PCoerce (cat2fid cat p)) | p <- ps])
-
-    mkLinDefRef (cat,_) =
-      (cat2fid cat 0,[0])
-
-    addProd prods (fid,prod) =
-      case IntMap.lookup fid prods of
-        Just set -> IntMap.insert fid (Set.insert prod set) prods
-        Nothing  -> IntMap.insert fid (Set.singleton prod)  prods
-
-    binSearch v arr (i,j)
-      | i <= j    = case compare v (arr ! k) of
-                      LT -> binSearch v arr (i,k-1)
-                      EQ -> k
-                      GT -> binSearch v arr (k+1,j)
-      | otherwise = error "binSearch"
-      where
-        k = (i+j) `div` 2
-
-    cat2fid cat p =
-      case Map.lookup (mkCId cat) cnccats of
-        Just (CncCat fid _ _) -> fid+p
-        _                     -> error "cat2fid"
-
-    cat2arg c@(cat,[p]) = cat2fid cat p
-    cat2arg c@(cat,ps ) =
-      case Map.lookup c cs of
-        Just fid -> fid
-        Nothing  -> error "cat2arg"
-
-mkRuleName rule =
-  case ruleName rule of
-    CFObj n _ -> n
-    _         -> wildCId

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

@@ -1,590 +0,0 @@
--- | Functions for computing the values of terms in the concrete syntax, in
--- | preparation for PMCFG generation.
-module GF.Compile.Compute.Concrete
-           (GlobalEnv, GLocation, resourceValues, geLoc, geGrammar,
-            normalForm,
-            Value(..), Bind(..), Env, value2term, eval, vapply
-           ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-
-import GF.Grammar hiding (Env, VGen, VApp, VRecType)
-import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
-import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
-import GF.Grammar.PatternMatch(matchPattern,measurePatt)
-import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
-import GF.Compile.Compute.Value hiding (Error)
-import GF.Compile.Compute.Predef(predef,predefName,delta)
-import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
-import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM)
-import GF.Data.Utilities(mapFst,mapSnd)
-import GF.Infra.Option
-import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
-import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
---import Data.Char (isUpper,toUpper,toLower)
-import GF.Text.Pretty
-import qualified Data.Map as Map
-import Debug.Trace(trace)
-
--- * Main entry points
-
-normalForm :: GlobalEnv -> L Ident -> Term -> Term
-normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
-
-nfx :: GlobalEnv -> Term -> Err Term
-nfx env@(GE _ _ _ loc) t = do
-  v <- eval env [] t
-  return (value2term loc [] v)
-    -- Old value2term error message:
-    -- Left i  -> fail ("variable #"++show i++" is out of scope")
-
-eval :: GlobalEnv -> Env -> Term -> Err Value
-eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
-  where
-    cenv = CE gr rvs opts loc (map fst env)
-
---apply env = apply' env
-
---------------------------------------------------------------------------------
-
--- * Environments
-
-type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
-
-data GlobalEnv = GE Grammar ResourceValues Options GLocation
-data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
-                       opts::Options,
-                       gloc::GLocation,local::LocalScope}
-type GLocation = L Ident
-type LocalScope = [Ident]
-type Stack = [Value]
-type OpenValue = Stack->Value
-
-geLoc     (GE _ _ _ loc) = loc
-geGrammar (GE gr _ _ _)  = gr
-
-ext b env = env{local=b:local env}
-extend bs env = env{local=bs++local env}
-global env = GE (srcgr env) (rvs env) (opts env) (gloc env)
-
-var :: CompleteEnv -> Ident -> Err OpenValue
-var env x = maybe unbound pick' (elemIndex x (local env))
-  where
-    unbound = fail ("Unknown variable: "++showIdent x)
-    pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs)
-    err i vs = bug $ "Stack problem: "++showIdent x++": "
-                    ++unwords (map showIdent (local env))
-                    ++" => "++show (i,length vs)
-    ok v = --trace ("var "++show x++" = "++show v) $
-           v
-
-pick :: Int -> Stack -> Maybe Value
-pick 0 (v:_) = Just v
-pick i (_:vs) = pick (i-1) vs
-pick i vs = Nothing -- bug $ "pick "++show (i,vs)
-
-resource env (m,c) =
---  err bug id $
-    if isPredefCat c
-    then value0 env =<< lockRecType c defLinType -- hmm
-    else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
-  where e = fail $ "Not found: "++render m++"."++showIdent c
-
--- | Convert operators once, not every time they are looked up
-resourceValues :: Options -> SourceGrammar -> GlobalEnv
-resourceValues opts gr = env
-  where
-    env = GE gr rvs opts (L NoLoc identW)
-    rvs = Map.mapWithKey moduleResources (moduleMap gr)
-    moduleResources m = Map.mapWithKey (moduleResource m) . jments
-    moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
-                                  let loc = L l c
-                                      qloc = L l (Q (m,c))
-                                  eval (GE gr rvs opts loc) [] (traceRes qloc t)
-
-    traceRes = if flag optTrace opts
-               then traceResource
-               else const id
-
--- * Tracing
-
--- | Insert a call to the trace function under the top-level lambdas
-traceResource (L l q) t =
-  case termFormCnc t of
-    (abs,body) -> mkAbs abs (mkApp traceQ [args,body])
-      where
-        args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
-        lstr = render (l<>":"<>ppTerm Qualified 0 q)
-        traceQ = Q (cPredef,cTrace)
-
--- * Computing values
-
--- | Computing the value of a top-level term
-value0 :: CompleteEnv -> Term -> Err Value
-value0 env = eval (global env) []
-
--- | Computing the value of a term
-value :: CompleteEnv -> Term -> Err OpenValue
-value env t0 =
-  -- Each terms is traversed only once by this function, using only statically
-  -- available information. Notably, the values of lambda bound variables
-  -- will be unknown during the term traversal phase.
-  -- The result is an OpenValue, which is a function that may be applied many
-  -- times to different dynamic values, but without the term traversal overhead
-  -- and without recomputing other statically known information.
-  -- For this to work, there should be no recursive calls under lambdas here.
-  -- Whenever we need to construct the OpenValue function with an explicit
-  -- lambda, we have to lift the recursive calls outside the lambda.
-  -- (See e.g. the rules for Let, Prod and Abs)
-{-
-  trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
-                                      brackets (fsep (map ppIdent (local env))),
-                                      ppTerm Unqualified 10 t0]) $
---}
-  errIn (render t0) $
-  case t0 of
-    Vr x   -> var env x
-    Q x@(m,f)
-      | m == cPredef -> if f==cErrorType                -- to be removed
-                        then let p = identS "P"
-                             in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
-                        else if f==cPBool
-                               then const # resource env x
-                               else const . flip VApp [] # predef f
-      | otherwise    -> const # resource env x --valueResDef (fst env) x
-    QC x   -> return $ const (VCApp x [])
-    App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
-    Let (x,(oty,t)) body -> do vb <- value (ext x env) body
-                               vt <- value env t
-                               return $ \ vs -> vb (vt vs:vs)
-    Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
-    Prod bt x t1 t2 ->
-       do vt1 <- value env t1
-          vt2 <- value (ext x env) t2
-          return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
-    Abs bt x t -> do vt <- value (ext x env) t
-                     return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
-    EInt n -> return $ const (VInt n)
-    EFloat f -> return $ const (VFloat f)
-    K s -> return $ const (VString s)
-    Empty -> return $ const (VString "")
-    Sort s | s == cTok -> return $ const (VSort cStr)        -- to be removed
-           | otherwise -> return $ const (VSort s)
-    ImplArg t -> (VImplArg.) # value env t
-    Table p res -> liftM2 VTblType # value env p <# value env res
-    RecType rs -> do lovs <- mapPairsM (value env) rs
-                     return $ \vs->VRecType $ mapSnd ($ vs) lovs
-    t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
-    FV ts   -> ((vfv .) # sequence) # mapM (value env) ts
-    R as    -> do lovs <- mapPairsM (value env.snd) as
-                  return $ \ vs->VRec $ mapSnd ($ vs) lovs
-    T i cs  -> valueTable env i cs
-    V ty ts -> do pvs <- paramValues env ty
-                  ((VV ty pvs .) . sequence) # mapM (value env) ts
-    C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2)
-    S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
-    P t l   -> --maybe (bug $ "project "++show l++" from "++show v) id $
-               do ov <- value env t
-                  return $ \ vs -> let v = ov vs
-                                   in maybe (VP v l) id (proj l v)
-    Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
-    Strs ts    -> ((VStrs.) # sequence) # mapM (value env) ts
-    Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
-    ELin c r -> (unlockVRec (gloc env) c.) # value env r
-    EPatt p  -> return $ const (VPatt p) -- hmm
-    EPattType ty -> do vt <- value env ty
-                       return (VPattType . vt)
-    Typed t ty -> value env t
-    t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t
-
-vconcat vv@(v1,v2) =
-    case vv of
-      (VString "",_) -> v2
-      (_,VString "") -> v1
-      (VApp NonExist _,_) -> v1
-      (_,VApp NonExist _) -> v2
-      _ -> VC v1 v2
-
-proj l v | isLockLabel l = return (VRec [])
-                ---- a workaround 18/2/2005: take this away and find the reason
-                ---- why earlier compilation destroys the lock field
-proj l v =
-    case v of
-      VFV vs -> liftM vfv (mapM (proj l) vs)
-      VRec rs -> lookup l rs
---    VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
-      VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs
-      _ -> return (ok1 VP v l)
-
-ok1 f v1@(VError {}) _ = v1
-ok1 f v1 v2 = f v1 v2
-
-ok2 f v1@(VError {}) _ = v1
-ok2 f _ v2@(VError {}) = v2
-ok2 f v1 v2 = f v1 v2
-
-ok2p f (v1@VError {},_) = v1
-ok2p f (_,v2@VError {}) = v2
-ok2p f vv = f vv
-
-unlockVRec loc c0 v0 = v0
-{-
-unlockVRec loc c0 v0 = unlockVRec' c0 v0
-  where
-    unlockVRec' ::Ident -> Value -> Value
-    unlockVRec' c v =
-        case v of
-    --    VClosure env t -> err bug (VClosure env) (unlockRecord c t)
-          VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v))
-          VRec rs        -> plusVRec rs lock
-    --    _              -> VExtR v (VRec lock) -- hmm
-          _              -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm
-    --    _              -> bugloc loc $ "unlock non-record "++show v0
-      where
-        lock = [(lockLabel c,VRec [])]
--}
-
--- suspicious, but backwards compatible
-plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
-  where ls2 = map fst rs2
-
-extR t vv =
-    case vv of
-      (VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
-      (v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
-      (VRecType rs1, VRecType rs2) ->
-          case intersect (map fst rs1) (map fst rs2) of
-            [] -> VRecType (rs1 ++ rs2)
-            ls -> error $ "clash"<+>show ls
-      (VRec     rs1, VRec     rs2) -> plusVRec rs1 rs2
-      (v1          , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
-      (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
---    (v1,v2) -> ok2 VExtR v1 v2 -- hmm
-      (v1,v2) -> error $ "not records" $$ show v1 $$ show v2
-  where
-    error explain = ppbug $ "The term" <+> t
-                            <+> "is not reducible" $$ explain
-
-glue env (v1,v2) = glu v1 v2
-  where
-    glu v1 v2 =
-        case (v1,v2) of
-          (VFV vs,v2) -> vfv [glu v1 v2|v1<-vs]
-          (v1,VFV vs) -> vfv [glu v1 v2|v2<-vs]
-          (VString s1,VString s2) -> VString (s1++s2)
-          (v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
-             where glx v2 = glu v1 v2
-          (v1@(VAlts {}),v2) ->
-           --err (const (ok2 VGlue v1 v2)) id $
-             err bug id $
-             do y' <- strsFromValue v2
-                x' <- strsFromValue v1
-                return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
-          (VC va vb,v2) -> VC va (glu vb v2)
-          (v1,VC va vb) -> VC (glu v1 va) vb
-          (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb
-          (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb
-          (v1@(VApp NonExist _),_) -> v1
-          (_,v2@(VApp NonExist _)) -> v2
---        (v1,v2) -> ok2 VGlue v1 v2
-          (v1,v2) -> if flag optPlusAsBind (opts env)
-                       then VC v1 (VC (VApp BIND []) v2)
-                       else let loc  = gloc env
-                                vt v = value2term loc (local env) v
-                                        -- Old value2term error message:
-                                        --  Left i  -> Error ('#':show i)
-                                originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
-                                                               (Glue (vt v1) (vt v2)))
-                                term = render $ pp  $ Glue (vt v1) (vt v2)
-                            in error $ unlines
-                                [originalMsg
-                                ,""
-                                ,"There was a problem in the expression `"++term++"`, either:"
-                                ,"1) You are trying to use + on runtime arguments, possibly via an oper."
-                                ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive."
-                                ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md"
-                                ]
-
-
--- | to get a string from a value that represents a sequence of terminals
-strsFromValue :: Value -> Err [Str]
-strsFromValue t = case t of
-  VString s   -> return [str s]
-  VC s t -> do
-    s' <- strsFromValue s
-    t' <- strsFromValue t
-    return [plusStr x y | x <- s', y <- t']
-{-
-  VGlue s t -> do
-    s' <- strsFromValue s
-    t' <- strsFromValue t
-    return [glueStr x y | x <- s', y <- t']
--}
-  VAlts d vs -> do
-    d0 <- strsFromValue d
-    v0 <- mapM (strsFromValue . fst) vs
-    c0 <- mapM (strsFromValue . snd) vs
-  --let vs' = zip v0 c0
-    return [strTok (str2strings def) vars |
-              def  <- d0,
-              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
-                                                          vv <- sequence v0]
-           ]
-  VFV ts -> concat # mapM strsFromValue ts
-  VStrs ts -> concat # mapM strsFromValue ts
-
-  _ -> fail ("cannot get Str from value " ++ show t)
-
-vfv vs = case nub vs of
-           [v] -> v
-           vs -> VFV vs
-
-select env vv =
-    case vv of
-      (v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs]
-      (VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs]
-      (v1@(VV pty vs rs),v2) ->
-         err (const (VS v1 v2)) id $
-         do --ats <- allParamValues (srcgr env) pty
-            --let vs = map (value0 env) ats
-            i <- maybeErr "no match" $ findIndex (==v2) vs
-            return (ix (gloc env) "select" rs i)
-      (VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
-      (v1@(VT _ _ cs),v2) ->
-                 err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
-                 match (gloc env) cs v2
-      (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
-      (v1,v2) -> ok2 VS v1 v2
-
-match loc cs v =
-  err bad return (matchPattern cs (value2term loc [] v))
-    -- Old value2term error message:
-    -- Left i  -> bad ("variable #"++show i++" is out of scope")
-  where
-    bad = fail . ("In pattern matching: "++)
-
-valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
-valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
-
-valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
-valueTable env i cs =
-    case i of
-      TComp ty -> do pvs <- paramValues env ty
-                     ((VV ty pvs .) # sequence) # mapM (value env.snd) cs
-      _ -> do ty <- getTableType i
-              cs' <- mapM valueCase cs
-              err (dynamic cs' ty) return (convert cs' ty)
-  where
-    dynamic cs' ty _ = cases cs' # value env ty
-
-    cases cs' vty vs = err keep ($ vs) (convertv cs' (vty vs))
-      where
-        keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $
-                   VT wild (vty vs) (mapSnd ($ vs) cs')
-
-    wild = case i of TWild _ -> True; _ -> False
-
-    convertv cs' vty =
-      convert' cs' =<< paramValues'' env (value2term (gloc env) [] vty)
-        -- Old value2term error message: Left i    -> fail ("variable #"++show i++" is out of scope")
-
-    convert cs' ty = convert' cs' =<< paramValues' env ty
-
-    convert' cs' ((pty,vs),pvs) =
-      do sts  <- mapM (matchPattern cs') vs
-         return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
-                                           (mapFst ($ vs) sts)
-
-    valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
-                         pvs <- linPattVars p'
-                         vt <- value (extend pvs env) t
-                         return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs))
-
-    inlinePattMacro p =
-        case p of
-          PM qc -> do r <- resource env qc
-                      case r of
-                        VPatt p' -> inlinePattMacro p'
-                        _ -> ppbug $ hang "Expected pattern macro:" 4
-                                          (show r)
-          _ -> composPattOp inlinePattMacro p
-
-
-paramValues env ty = snd # paramValues' env ty
-
-paramValues' env ty = paramValues'' env =<< nfx (global env) ty
-
-paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
-                           pvs <- mapM (eval (global env) []) ats
-                           return ((pty,ats),pvs)
-
-push' p bs xs = if length bs/=length xs
-                then bug $ "push "++show (p,bs,xs)
-                else push bs xs
-
-push :: Env -> LocalScope -> Stack -> Stack
-push bs [] vs = vs
-push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
-  where  err = bug $ "Unbound pattern variable "++showIdent x
-
-apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
-apply' env t [] = value env t
-apply' env t vs =
-  case t of
-    QC x                   -> return $ \ svs -> VCApp x (map ($ svs) vs)
-{-
-    Q x@(m,f) | m==cPredef -> return $
-                              let constr = --trace ("predef "++show x) .
-                                           VApp x
-                              in \ svs -> maybe constr id (Map.lookup f predefs)
-                                          $ map ($ svs) vs
-              | otherwise  -> do r <- resource env x
-                                 return $ \ svs -> vapply (gloc env) r (map ($ svs) vs)
--}
-    App t1 t2              -> apply' env t1 . (:vs) =<< value env t2
-    _                      -> do fv <- value env t
-                                 return $ \ svs -> vapply (gloc env) (fv svs) (map ($ svs) vs)
-
-vapply :: GLocation -> Value -> [Value] -> Value
-vapply loc v [] = v
-vapply loc v vs =
-  case v of
-    VError {} -> v
---  VClosure env (Abs b x t) -> beta gr env b x t vs
-    VAbs bt _ (Bind f) -> vbeta loc bt f vs
-    VApp pre vs1 -> delta' pre (vs1++vs)
-      where
-        delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
-                                  in vtrace loc v1 vr
-        delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
-        --msg = const (VApp pre (vs1++vs))
-        msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
-    VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
-    VFV fs -> vfv [vapply loc f vs|f<-fs]
-    VCApp f vs0 -> VCApp f (vs0++vs)
-    VMeta i env vs0 -> VMeta i env (vs0++vs)
-    VGen i vs0 -> VGen i (vs0++vs)
-    v -> bug $ "vapply "++show v++" "++show vs
-
-vbeta loc bt f (v:vs) =
-  case (bt,v) of
-    (Implicit,VImplArg v) -> ap v
-    (Explicit,         v) -> ap v
-  where
-    ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
-    ap v         = vapply loc (f v) vs
-
-vary (VFV vs) = vs
-vary v = [v]
-varyList = mapM vary
-
-{-
-beta env b x t (v:vs) =
-  case (b,v) of
-    (Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
-    (Explicit,         v) -> apply' (ext (x,v) env) t vs
--}
-
-vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
-  where
-    pv v = case v of
-             VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
-             _ -> ppV v
-    pf (_,VString n) = pp n
-    pf (_,v) = ppV v
-    pa (_,v) = ppV v
-    ppV v = ppTerm Unqualified 10 (value2term' True loc [] v)
-              -- Old value2term error message:
-              -- Left i  -> "variable #" <> pp i <+> "is out of scope"
-
--- | Convert a value back to a term
-value2term :: GLocation -> [Ident] -> Value -> Term
-value2term = value2term' False
-
-value2term' :: Bool -> p -> [Ident] -> Value -> Term
-value2term' stop loc xs v0 =
-  case v0 of
-    VApp pre vs    -> applyMany (Q (cPredef,predefName pre)) vs
-    VCApp f vs     -> applyMany (QC f)                       vs
-    VGen j vs      -> applyMany (var j)                      vs
-    VMeta j env vs -> applyMany (Meta j)                     vs
-    VProd bt v x f -> Prod bt x (v2t v)  (v2t' x f)
-    VAbs  bt   x f -> Abs  bt x          (v2t' x f)
-    VInt n         -> EInt n
-    VFloat f       -> EFloat f
-    VString s      -> if null s then Empty else K s
-    VSort s        -> Sort s
-    VImplArg v     -> ImplArg (v2t v)
-    VTblType p res -> Table (v2t p) (v2t res)
-    VRecType rs    -> RecType [(l, v2t v) | (l,v) <- rs]
-    VRec as        -> R       [(l, (Nothing, v2t v)) | (l,v) <- as]
-    VV t _ vs      -> V t     (map v2t vs)
-    VT wild v cs   -> T ((if wild then TWild else TTyped) (v2t v)) (map nfcase cs)
-    VFV vs         -> FV (map v2t vs)
-    VC v1 v2       -> C (v2t v1) (v2t v2)
-    VS v1 v2       -> S (v2t v1) (v2t v2)
-    VP v l         -> P (v2t v) l
-    VPatt p        -> EPatt p
-    VPattType v    -> EPattType $ v2t v
-    VAlts v vvs    -> Alts (v2t v) [(v2t x, v2t y) | (x,y) <- vvs]
-    VStrs vs       -> Strs (map v2t vs)
---  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
---  VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
-    VError err     -> Error err
-  where
-    applyMany f vs = foldl App f (map v2t vs)
-    v2t = v2txs xs
-    v2txs = value2term' stop loc
-    v2t' x f = v2txs (x:xs) (bind f (gen xs))
-
-    var j
-      | j<length xs = Vr (reverse xs !! j)
-      | otherwise   = error ("variable #"++show j++" is out of scope")
-
-
-    pushs xs e = foldr push e xs
-    push x (env,xs) = ((x,gen xs):env,x:xs)
-    gen xs = VGen (length xs) []
-
-    nfcase (p,f) = (,) p (v2txs xs' (bind f env'))
-      where (env',xs') = pushs (pattVars p) ([],xs)
-
-    bind (Bind f) x = if stop
-                      then VSort (identS "...") -- hmm
-                      else f x
-
-
-linPattVars p =
-    if null dups
-    then return pvs
-    else fail.render $ hang "Pattern is not linear. All variable names on the left-hand side must be distinct." 4 (ppPatt Unqualified 0 p)
-  where
-    allpvs = allPattVars p
-    pvs = nub allpvs
-    dups = allpvs \\ pvs
-
-pattVars = nub . allPattVars
-allPattVars p =
-    case p of
-      PV i    -> [i]
-      PAs i p -> i:allPattVars p
-      _       -> collectPattOp allPattVars p
-
----
-ix loc fn xs i =
-    if i<n
-    then xs !! i
-    else bugloc loc $ "(!!): index too large in "++fn++", "++show i++"<"++show n
-  where n = length xs
-
-infixl 1 #,<# --,@@
-
-f # x = fmap f x
-mf <# mx  = ap mf mx
---m1 @@ m2 = (m1 =<<) . m2
-
-both f (x,y) = (,) # f x <# f y
-
-bugloc loc s = ppbug $ ppL loc s
-
-bug msg = ppbug msg
-ppbug doc = error $ render $ hang "Internal error in Compute.Concrete:" 4 doc

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

@@ -1,172 +0,0 @@
--- | Implementations of predefined functions
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-module GF.Compile.Compute.Predef(predef,predefName,delta) where
-
-import qualified Data.Map as Map
-import Data.Array(array,(!))
-import Data.List (isInfixOf)
-import Data.Char (isUpper,toLower,toUpper)
-import Control.Monad(ap)
-
-import GF.Data.Utilities (apBoth) --mapSnd
-
-import GF.Compile.Compute.Value
-import GF.Infra.Ident (Ident,showIdent) --,varX
-import GF.Data.Operations(Err) -- ,err
-import GF.Grammar.Predef
-
---------------------------------------------------------------------------------
-class Predef a where
-  toValue :: a -> Value
-  fromValue :: Value -> Err a
-
-instance Predef Int where
-  toValue = VInt
-  fromValue (VInt i) = return i
-  fromValue v = verror "Int" v
-
-instance Predef Bool where
-  toValue = boolV
-  fromValue v = case v of
-    VCApp (mn,i) [] | mn == cPredef && i == cPTrue -> return True
-    VCApp (mn,i) [] | mn == cPredef && i == cPFalse -> return False
-    _ -> verror "Bool" v
-
-instance Predef String where
-  toValue = string
-  fromValue v = case norm v of
-                  VString s -> return s
-                  _ -> verror "String" v
-
-instance Predef Value where
-  toValue = id
-  fromValue = return
-
-instance Predef Predefined where
-  toValue p = VApp p []
-  fromValue v = case v of
-                  VApp p _ -> return p
-                  _        -> fail $ "Expected a predefined constant, got something else"
-
-{-
-instance (Predef a,Predef b) => Predef (a->b) where
-  toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue
--}
-verror t v =
-  case v of
-    VError e -> fail e
-    VGen {}  -> fail $ "Expected a static value of type "++t
-                       ++", got a dynamic value"
-    _ -> fail $ "Expected a value of type "++t++", got "++show v
-
---------------------------------------------------------------------------------
-
-predef f = maybe undef return (Map.lookup f predefs)
-  where
-    undef = fail $ "Unimplemented predfined operator: Predef."++showIdent f
-
-predefs :: Map.Map Ident Predefined
-predefs = Map.fromList predefList
-
-predefName pre = predefNames ! pre
-predefNames = array (minBound,maxBound) (map swap predefList)
-
-predefList =
-    [(cDrop,Drop),(cTake,Take),(cTk,Tk),(cDp,Dp),(cEqStr,EqStr),
-     (cOccur,Occur),(cOccurs,Occurs),(cToUpper,ToUpper),(cToLower,ToLower),
-     (cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
-     (cLessInt,LessInt),
-     -- cShow, cRead, cMapStr, cEqVal
-     (cError,Error),(cTrace,Trace),
-     -- Canonical values:
-     (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int),(cFloat,Float),
-     (cInts,Ints),(cNonExist,NonExist)
-     ,(cBIND,BIND),(cSOFT_BIND,SOFT_BIND),(cSOFT_SPACE,SOFT_SPACE)
-     ,(cCAPIT,CAPIT),(cALL_CAPIT,ALL_CAPIT)]
-    --- add more functions!!!
-
-delta f vs =
-    case f of
-      Drop    -> fromNonExist vs NonExist (ap2 (drop::Int->String->String))
-      Take    -> fromNonExist vs NonExist (ap2 (take::Int->String->String))
-      Tk      -> fromNonExist vs NonExist (ap2 tk)
-      Dp      -> fromNonExist vs NonExist (ap2 dp)
-      EqStr   -> fromNonExist vs PFalse   (ap2 ((==)::String->String->Bool))
-      Occur   -> fromNonExist vs PFalse   (ap2 occur)
-      Occurs  -> fromNonExist vs PFalse   (ap2 occurs)
-      ToUpper -> fromNonExist vs NonExist (ap1 (map toUpper))
-      ToLower -> fromNonExist vs NonExist (ap1 (map toLower))
-      IsUpper -> fromNonExist vs PFalse   (ap1 (all' isUpper))
-      Length  -> fromNonExist vs (0::Int) (ap1 (length::String->Int))
-      Plus    -> ap2 ((+)::Int->Int->Int)
-      EqInt   -> ap2 ((==)::Int->Int->Bool)
-      LessInt -> ap2 ((<)::Int->Int->Bool)
-    {- -- | Show | Read | ToStr | MapStr | EqVal -}
-      Error   -> ap1 VError
-      Trace   -> ap2 vtrace
-      -- Canonical values:
-      PBool   -> canonical
-      Int     -> canonical
-      Float   -> canonical
-      Ints    -> canonical
-      PFalse  -> canonical
-      PTrue   -> canonical
-      NonExist-> canonical
-      BIND    -> canonical
-      SOFT_BIND->canonical
-      SOFT_SPACE->canonical
-      CAPIT   -> canonical
-      ALL_CAPIT->canonical
-  where
-    canonical = delay
-    delay = return (VApp f vs) -- wrong number of arguments
-
-    ap1 f = case vs of
-              [v1] -> (toValue . f) `fmap` fromValue v1
-              _ -> delay
-
-    ap2 f = case vs of
-             [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
-             _ -> delay
-
-    fromNonExist vs a b
-      | null [v | v@(VApp NonExist _) <- vs] = b
-      | otherwise                            = return (toValue a)
-
-    vtrace :: Value -> Value -> Value
-    vtrace x y = y -- tracing is implemented elsewhere
-
---  unimpl id = bug $ "unimplemented predefined function: "++showIdent id
---  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
-
-    tk i s = take (max 0 (length s - i)) s :: String
-    dp i s = drop (max 0 (length s - i)) s :: String
-    occur s t = isInfixOf (s::String) (t::String)
-    occurs s t = any (`elem` (t::String)) (s::String)
-    all' = all :: (a->Bool) -> [a] -> Bool
-
-boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
-
-norm v =
-  case v of
-    VC v1 v2 -> case apBoth norm (v1,v2) of
-                  (VString s1,VString s2) -> VString (s1++" "++s2)
-                  (v1,v2) -> VC v1 v2
-    _ -> v
-{-
-strict v = case v of
-             VError err -> Left err
-             _ -> Right v
--}
-string s = case words s of
-             [] -> VString ""
-             ss -> foldr1 VC (map VString ss)
-
----
-
-swap (x,y) = (y,x)
-{-
-bug msg = ppbug msg
-ppbug doc = error $ render $
-                    hang "Internal error in Compute.Predef:" 4 doc
--}

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

@@ -1,56 +0,0 @@
-module GF.Compile.Compute.Value where
-import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent)
-import PGF.Internal(BindType)
-import GF.Infra.Ident(Ident)
-import Text.Show.Functions()
-import Data.Ix(Ix)
-
--- | Self-contained (not quite) representation of values
-data Value
-  = VApp Predefined [Value] -- from Q, always Predef.x, has a built-in value
-  | VCApp QIdent [Value] -- from QC, constructors
-  | VGen Int [Value] -- for lambda bound variables, possibly applied
-  | VMeta MetaId Env [Value]
--- -- | VClosure Env Term -- used in Typecheck.ConcreteNew
-  | VAbs BindType Ident Binding -- used in Compute.Concrete
-  | VProd BindType Value Ident Binding -- used in Compute.Concrete
-  | VInt Int
-  | VFloat Double
-  | VString String
-  | VSort Ident
-  | VImplArg Value
-  | VTblType Value Value
-  | VRecType [(Label,Value)]
-  | VRec [(Label,Value)]
-  | VV Type [Value] [Value] -- preserve type for conversion back to Term
-  | VT Wild Value [(Patt,Bind Env)]
-  | VC Value Value
-  | VS Value Value
-  | VP Value Label
-  | VPatt Patt
-  | VPattType Value
-  | VFV [Value]
-  | VAlts Value [(Value, Value)]
-  | VStrs [Value]
--- -- | VGlue Value Value -- hmm
--- --  | VExtR Value Value -- hmm
-  | VError String
-  deriving (Eq,Show)
-
-type Wild = Bool
-type Binding = Bind Value
-data Bind a = Bind (a->Value) deriving Show
-
-instance Eq (Bind a) where x==y = False
-
-type Env = [(Ident,Value)]
-
--- | Predefined functions
-data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
-                | ToLower | IsUpper | Length | Plus | EqInt | LessInt
-             {- | Show | Read | ToStr | MapStr | EqVal -}
-                | Error | Trace
-                -- Canonical values below:
-                | PBool | PFalse | PTrue | Int | Float | Ints | NonExist
-                | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
-                deriving (Show,Eq,Ord,Ix,Bounded,Enum)

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -1,415 +0,0 @@
--- | Translate concrete syntax to Haskell
-module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
-import Data.List(isPrefixOf,sort,sortOn)
-import qualified Data.Map as M
-import qualified Data.Set as S
-import GF.Text.Pretty
---import GF.Grammar.Predef(cPredef,cInts)
---import GF.Compile.Compute.Predef(predef)
---import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
-import GF.Infra.Option
-import GF.Haskell as H
-import GF.Grammar.Canonical as C
-import GF.Compile.GrammarToCanonical
-import Debug.Trace(trace)
-
--- | Generate Haskell code for the all concrete syntaxes associated with
--- the named abstract syntax in given the grammar.
-concretes2haskell opts absname gr =
-  [(filename,render80 $ concrete2haskell opts abstr cncmod)
-     | let Grammar abstr cncs = grammar2canonical opts absname gr,
-       cncmod<-cncs,
-       let ModId name = concName cncmod
-           filename = showRawIdent name ++ ".hs" :: FilePath
-  ]
-
--- | Generate Haskell code for the given concrete module.
--- The only options that make a difference are
--- @-haskell=noprefix@ and @-haskell=variants@.
-concrete2haskell opts
-                 abstr@(Abstract _ _ cats funs)
-                 modinfo@(Concrete cnc absname _ ps lcs lns) =
-  haskPreamble absname cnc $$
-  vcat (
-    nl:Comment "--- Parameter types ---":
-    map paramDef ps ++
-    nl:Comment "--- Type signatures for linearization functions ---":
-    map signature cats ++
-    nl:Comment "--- Linearization functions for empty categories ---":
-    emptydefs ++
-    nl:Comment "--- Linearization types ---":
-    map lincatDef lcs ++
-    nl:Comment "--- Linearization functions ---":
-    lindefs ++
-    nl:Comment "--- Type classes for projection functions ---":
-    map labelClass (S.toList labels) ++
-    nl:Comment "--- Record types ---":
-    concatMap recordType recs)
-  where
-    nl = Comment ""
-    recs = S.toList (S.difference (records (lcs,lns)) common_records)
-
-    labels = S.difference (S.unions (map S.fromList recs)) common_labels
-    common_records = S.fromList [[label_s]]
-    common_labels = S.fromList [label_s]
-    label_s = LabelId (rawIdentS "s")
-
-    signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
-      where
-        abs = tcon0 (prefixIdent "A." (gId c))
-        lin = tcon0 lc
-        lf = linfunName c
-        lc = lincatName c
-
-    emptydefs = map emptydef (S.toList emptyCats)
-    emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
-
-    emptyCats = allcats `S.difference` linfuncats
-      where
-     --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
-       allcats = S.fromList [c | CatDef c _<-cats]
-
-    gId :: ToIdent i => i -> Ident
-    gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
-          . toIdent
-
-    va = haskellOption opts HaskellVariants
-    pure = if va then ListT else id
-
-    haskPreamble :: ModId -> ModId -> Doc
-    haskPreamble absname cncname =
-      "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
-      "module" <+> cncname <+> "where" $$
-      "import Prelude hiding (Ordering(..))" $$
-      "import Control.Applicative((<$>),(<*>))" $$
-      "import PGF.Haskell" $$
-      "import qualified" <+> absname <+> "as A" $$
-      "" $$
-      "--- Standard definitions ---" $$
-      "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
-      "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
-      "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
-      "" $$
-      "----------------------------------------------------" $$
-      "-- Automatic translation from GF to Haskell follows" $$
-      "----------------------------------------------------"
-      where
-        pure = if va then brackets else pp
-
-    paramDef pd =
-      case pd of
-        ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
-        ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
-          where
-            paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
-            derive = ["Eq","Ord","Show"]
-
-    convLinType = ppT
-      where
-        ppT t =
-          case t of
-            FloatType -> tcon0 (identS "Float")
-            IntType -> tcon0 (identS "Int")
-            ParamType (ParamTypeId p) -> tcon0 (gId p)
-            RecordType rs -> tcon (rcon' ls) (map ppT ts)
-              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
-            StrType -> tcon0 (identS "Str")
-            TableType pt lt -> Fun (ppT pt) (ppT lt)
---          TupleType lts ->
-
-    lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
-
-    linfuncats = S.fromList linfuncatl
-    (linfuncatl,lindefs) = unzip (linDefs lns)
-
-    linDefs = map eqn . sortOn fst . map linDef
-      where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
-
-    linDef (LinDef f xs rhs0) =
-        (cat,(linfunName cat,(lhs,rhs)))
-      where
-        lhs = [ConP (aId f) (map VarP abs_args)]
-        aId f = prefixIdent "A." (gId f)
-
-        [lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
-        [C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
-
-        abs_args = map abs_arg args
-        abs_arg = prefixIdent "abs_"
-        args = map (prefixIdent "g" . toIdent) xs
-
-        rhs = lets (zipWith letlin args absctx)
-                   (convert vs (coerce env lincat rhs0))
-          where
-            vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
-            env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
-
-        letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
-          (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
-
-        arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
-          where
-            [lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
-
-    convert = convert' va
-
-    convert' va vs = ppT
-      where
-        ppT0 = convert' False vs
-        ppTv vs' = convert' va vs'
-
-        pure = if va then single else id
-
-        ppT t =
-          case t of
-            TableValue ty cs -> pure (table cs)
-            Selection t p -> select (ppT t) (ppT p)
-            ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
-            RecordValue r -> aps (rcon ls) (map ppT ts)
-              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
-            PredefValue p -> single (Var (toIdent p)) -- hmm
-            Projection t l -> ap (proj l) (ppT t)
-            VariantValue [] -> empty
-            VariantValue ts@(_:_) -> variants ts
-            VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
-            PreValue vs t' -> pure (alts t' vs)
-            ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
-            ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
-            LiteralValue l -> ppL l
-            _ -> error ("convert "++show t)
-
-        ppL l =
-          case l of
-            FloatConstant x -> pure (lit x)
-            IntConstant n -> pure (lit n)
-            StrConstant s -> pure (token s)
-
-        pId p@(ParamId s) =
-          if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
-
-        table cs =
-            if all (null.patVars) ps
-            then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
-            else LambdaCase (map ppCase cs)
-          where
-            (ds,ts') = dedup ts
-            (ps,ts) = unzip [(p,t)|TableRow p t<-cs]
-        ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
-{-
-        ppPredef n =
-          case predef n of
-            Ok BIND       -> single (c "BIND")
-            Ok SOFT_BIND  -> single (c "SOFT_BIND")
-            Ok SOFT_SPACE -> single (c "SOFT_SPACE")
-            Ok CAPIT      -> single (c "CAPIT")
-            Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
-            _ -> Var n
--}
-        ppP p =
-          case p of
-            ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
-            RecordPattern r -> ConP (rcon' ls) (map ppP ps)
-              where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
-            WildPattern -> WildP
-
-        token s = single (c "TK" `Ap` lit s)
-
-        alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
-          where
-            alt (s,t) = Pair (List (pre s)) (ppT0 t)
-            pre s = map lit s
-
-        c = Const
-        lit s = c (show s) -- hmm
-        concat = if va then concat' else plusplus
-          where
-            concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
-            concat' t1 t2 = Op t1 "+++" t2
-
-        pure' = single -- forcing the list monad
-
-        select = if va then select' else Ap
-        select' (List [t]) (List [p]) = Op t "!" p
-        select' (List [t]) p = Op t "!$" p
-        select' t p = Op t "!*" p
-
-        ap = if va then ap' else Ap
-          where
-            ap' (List [f]) x = fmap f x
-            ap' f x = Op f "<*>" x
-            fmap f (List [x]) = pure' (Ap f x)
-            fmap f x = Op f "<$>" x
-
-    --  join = if va then join' else id
-        join' (List [x]) = x
-        join' x = c "concat" `Ap` x
-
-        empty = if va then List [] else c "error" `Ap` c (show "empty variant")
-        variants = if va then \ ts -> join' (List (map ppT ts))
-                         else \ (t:_) -> ppT t
-
-        aps f [] = f
-        aps f (a:as) = aps (ap f a) as
-
-        dedup ts =
-            if M.null dups
-            then ([],map ppT ts)
-            else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
-          where
-            entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
-            ev i = identS ("e'"++show i)
-
-            defs = [(i1,t)|(t,i1:_:_)<-ms]
-            dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
-            ms = M.toList m
-            m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
-            is = [0..]::[Int]
-
-
---con = Cn . identS
-
-class Records t where
-  records :: t -> S.Set [LabelId]
-
-instance Records t => Records [t] where
-  records = S.unions . map records
-
-instance (Records t1,Records t2) => Records (t1,t2) where
-  records (t1,t2) = S.union (records t1) (records t2)
-
-instance Records LincatDef where
-  records (LincatDef _ lt) = records lt
-
-instance Records LinDef where
-  records (LinDef _ _ lv) = records lv
-
-instance Records LinType where
-  records t =
-    case t of
-      RecordType r -> rowRecords r
-      TableType pt lt -> records (pt,lt)
-      TupleType ts -> records ts
-      _ -> S.empty
-
-rowRecords r = S.insert (sort ls) (records ts)
-  where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
-
-instance Records LinValue where
-  records v =
-    case v of
-      ConcatValue v1 v2 -> records (v1,v2)
-      ParamConstant (Param c vs) -> records vs
-      RecordValue r -> rowRecords r
-      TableValue t r -> records (t,r)
-      TupleValue vs -> records vs
-      VariantValue vs -> records vs
-      PreValue alts d -> records (map snd alts,d)
-      Projection v l -> records v
-      Selection v1 v2 -> records (v1,v2)
-      _ -> S.empty
-
-instance Records rhs => Records (TableRow rhs) where
-  records (TableRow _ v) = records v
-
-
--- | Record subtyping is converted into explicit coercions in Haskell
-coerce env ty t =
-  case (ty,t) of
-    (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
-    (TableType ti tv,TableValue _ cs) ->
-      TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
-    (RecordType rt,RecordValue r) ->
-      RecordValue [RecordRow l (coerce env ft f) |
-                     RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
-    (RecordType rt,VarValue x)->
-      case lookup x env of
-        Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
-                            --trace ("coerce "++render ty'++" to "++render ty) $
-                            app (to_rcon rt) [t]
-                 | otherwise -> t -- types match, no coercion needed
-        _ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
-                            $$ "in" <+> map fst env))
-                   t
-    _ -> t
-  where
-    app f ts = ParamConstant (Param f ts) -- !! a hack
-    to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
-
-patVars p = []
-
-labels r = [l | RecordRow l _ <- r]
-
-proj = Var . identS . proj'
-proj' (LabelId l) = "proj_" ++ showRawIdent l
-rcon = Var . rcon'
-rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
-to_rcon' = ("to_"++) . rcon_name
-
-recordType ls =
-    Data lhs [app] ["Eq","Ord","Show"]:
-    enumAllInstance:
-    zipWith projection vs ls ++
-    [Eqn (identS (to_rcon' ls),[VarP r])
-         (foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])]
-  where
-    r = identS "r"
-    cn = rcon' ls
- -- Not all record labels are syntactically correct as type variables in Haskell
- -- app = cn<+>ls
-    lhs = ConAp cn vs -- don't reuse record labels
-    app = fmap TId lhs
-    tapp = foldl TAp (TId cn) (map TId vs)
-    vs = [identS ('t':show i)|i<-[1..n]]
-    n = length ls
-
-    projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v)
-                              [((prj,[papp]),Var v)]
-     where
-       name = identS ("Has_"++render l)
-       prj = identS (proj' l)
-       papp = ConP cn (map VarP vs)
-
-    enumAllInstance =
-       Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)]
-      where
-        ctx =  [tEnumAll `TAp` TId v|v<-vs]
-        tEnumAll = TId (identS "EnumAll")
-
-labelClass l =
-    Class [] (ConAp name [r,a]) [([r],[a])]
-          [(identS (proj' l),TId r `Fun` TId a)]
-  where
-    name = identS ("Has_"++render l)
-    r = identS "r"
-    a = identS "a"
-
-enumCon name arity =
-    if arity==0
-    then single (Var name)
-    else foldl ap (single (Var name)) (replicate arity (Const "enumAll"))
-  where
-    ap (List [f]) a = Op f "<$>" a
-    ap f a = Op f "<*>" a
-
-lincatName,linfunName :: CatId -> Ident
-lincatName c = prefixIdent "Lin" (toIdent c)
-linfunName c = prefixIdent "lin" (toIdent c)
-
-class ToIdent i where toIdent :: i -> Ident
-
-instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
-instance ToIdent PredefId where toIdent (PredefId s) = identC s
-instance ToIdent CatId   where toIdent (CatId s) = identC s
-instance ToIdent C.FunId where toIdent (FunId s) = identC s
-instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
-
-qIdentC = identS . unqual
-
-unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
-unqual (Unqual n) = showRawIdent n
-
-instance ToIdent VarId where
-  toIdent Anonymous = identW
-  toIdent (VarId s) = identC s

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -1,640 +0,0 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
-----------------------------------------------------------------------
--- |
--- Maintainer  : Krasimir Angelov
--- Stability   : (stable)
--- Portability : (portable)
---
--- Convert PGF grammar to PMCFG grammar.
---
------------------------------------------------------------------------------
-
-module GF.Compile.GeneratePMCFG
-    (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
-    ) where
-
---import PGF.CId
-import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)
-
-import GF.Infra.Option
-import GF.Grammar hiding (Env, mkRecord, mkTable)
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Grammar.Lockfield (isLockLabel)
-import GF.Data.BacktrackM
-import GF.Data.Operations
-import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
-import GF.Data.Utilities (updateNthM) --updateNth
-import GF.Compile.Compute.Concrete(normalForm,resourceValues)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Data.List as List
---import qualified Data.IntMap as IntMap
-import qualified Data.IntSet as IntSet
-import GF.Text.Pretty
-import Data.Array.IArray
-import Data.Array.Unboxed
---import Data.Maybe
---import Data.Char (isDigit)
-import Control.Applicative(Applicative(..))
-import Control.Monad
-import Control.Monad.Identity
---import Control.Exception
---import Debug.Trace(trace)
-import qualified Control.Monad.Fail as Fail
-
-----------------------------------------------------------------------
--- main conversion function
-
---generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
-generatePMCFG opts sgr opath cmo@(cm,cmi) = do
-  (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv opath am cm) Map.empty (jments cmi)
-  when (verbAtLeast opts Verbose) $ ePutStrLn ""
-  return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
-  where
-    cenv = resourceValues opts gr
-    gr = prependModule sgr cmo
-    MTConcrete am = mtype cmi
-
-mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
-                                     -> Map.Map k b -> m (a,Map.Map k c)
-mapAccumWithKeyM f a m = do let xs = Map.toAscList m
-                            (a,ys) <- mapAccumM f a xs
-                            return (a,Map.fromAscList ys)
-  where
-    mapAccumM f a []          = return (a,[])
-    mapAccumM f a ((k,x):kxs) = do (a,y ) <- f a k x
-                                   (a,kys) <- mapAccumM f a kxs
-                                   return (a,(k,y):kys)
-
-
---addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
---when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
-  let pres  = protoFCat gr res val
-      pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
-
-      pmcfgEnv0   = emptyPMCFGEnv
-  b             <- convert opts gr cenv (floc opath loc id) term (cont,val) pargs
-  let (seqs1,b1) = addSequencesB seqs b
-      pmcfgEnv1  = foldBM addRule
-                          pmcfgEnv0
-                          (goB b1 CNil [])
-                          (pres,pargs)
-      pmcfg      = getPMCFG pmcfgEnv1
-
-      stats      = let PMCFG prods funs = pmcfg
-                       (s,e)            = bounds funs
-                       !prods_cnt       = length prods
-                       !funs_cnt        = e-s+1
-                   in (prods_cnt,funs_cnt)
-
-  when (verbAtLeast opts Verbose) $
-    ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
-  seqs1 `seq` stats `seq` return ()
-  when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
-  return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
-  where
-    (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
-
-    addRule lins (newCat', newArgs') env0 =
-      let [newCat] = getFIds newCat'
-          !fun     = mkArray lins
-          newArgs  = map getFIds newArgs'
-      in addFunction env0 newCat fun newArgs
-
-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
-                                                             mdef@(Just (L loc1 def))
-                                                             mref@(Just (L loc2 ref))
-                                                             mprn
-                                                             Nothing) = do
-  let pcat = protoFCat gr (am,id) lincat
-      pvar = protoFCat gr (MN identW,cVar) typeStr
-
-      pmcfgEnv0  = emptyPMCFGEnv
-
-  let lincont    = [(Explicit, varStr, typeStr)]
-  b             <- convert opts gr cenv (floc opath loc1 id) def (lincont,lincat) [pvar]
-  let (seqs1,b1) = addSequencesB seqs b
-      pmcfgEnv1  = foldBM addLindef
-                          pmcfgEnv0
-                          (goB b1 CNil [])
-                          (pcat,[pvar])
-
-  let lincont    = [(Explicit, varStr, lincat)]
-  b             <- convert opts gr cenv (floc opath loc2 id) ref (lincont,typeStr) [pcat]
-  let (seqs2,b2) = addSequencesB seqs1 b
-      pmcfgEnv2  = foldBM addLinref
-                          pmcfgEnv1
-                          (goB b2 CNil [])
-                          (pvar,[pcat])
-
-  let pmcfg     = getPMCFG pmcfgEnv2
-
-  when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
-  seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
-  where
-    addLindef lins (newCat', newArgs') env0 =
-      let [newCat] = getFIds newCat'
-          !fun     = mkArray lins
-      in addFunction env0 newCat fun [[fidVar]]
-
-    addLinref lins (newCat', [newArg']) env0 =
-      let newArg   = getFIds newArg'
-          !fun     = mkArray lins
-      in addFunction env0 fidVar fun [newArg]
-
-addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
-
-floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath
-
-convert opts gr cenv loc term ty@(_,val) pargs =
-  case normalForm cenv loc (etaExpand ty term) of
-    Error s -> fail $ render $ ppL loc ("Predef.error: "++s)
-    term    -> return $ runCnvMonad gr (convertTerm opts CNil val term) (pargs,[])
-  where
-    etaExpand (context,val) = mkAbs pars . flip mkApp args
-      where pars = [(Explicit,v) | v <- vars]
-            args = map Vr vars
-            vars = map (\(bt,x,t) -> x) context
-
-pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
-pgfCncCat gr lincat index =
-  let ((_,size),schema) = computeCatRange gr lincat
-  in PGF.CncCat index (index+size-1)
-                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
-                                    (getStrPaths schema)))
-  where
-    getStrPaths :: Schema Identity s c -> [Path]
-    getStrPaths = collect CNil []
-      where
-        collect path paths (CRec rs)   = foldr (\(lbl,Identity t) paths -> collect (CProj lbl path) paths t) paths rs
-        collect path paths (CTbl _ cs) = foldr (\(trm,Identity t) paths -> collect (CSel  trm path) paths t) paths cs
-        collect path paths (CStr _)    = reversePath path : paths
-        collect path paths (CPar _)    = paths
-
-----------------------------------------------------------------------
--- CnvMonad monad
---
--- The branching monad provides backtracking together with
--- recording of the choices made. We have two cases
--- when we have alternative choices:
---
---      * when we have parameter type, then
---        we have to try all possible values
---      * when we have variants we have to try all alternatives
---
--- The conversion monad keeps track of the choices and they are
--- returned as 'Branch' data type.
-
-data Branch a
-  = Case Int Path [(Term,Branch a)]
-  | Variant [Branch a]
-  | Return  a
-
-newtype CnvMonad a = CM {unCM :: SourceGrammar
-                              -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b)
-                              -> ([ProtoFCat],[Symbol])
-                              -> Branch b}
-
-instance Fail.MonadFail CnvMonad where
-  fail = bug
-
-instance Applicative CnvMonad where
-  pure a = CM (\gr c s -> c a s)
-  (<*>) = ap
-
-instance Monad CnvMonad where
-    return     = pure
-    CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s)
-
-instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where
-    get = CM (\gr c s -> c s s)
-    put s = CM (\gr c _ -> c () s)
-
-instance Functor CnvMonad where
-    fmap f (CM m) = CM (\gr c s -> m gr (c . f) s)
-
-runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a
-runCnvMonad gr (CM m) s = m gr (\v s -> Return v) s
-
--- | backtracking for all variants
-variants :: [a] -> CnvMonad a
-variants xs = CM (\gr c s -> Variant [c x s | x <- xs])
-
--- | backtracking for all parameter values that a variable could take
-choices :: Int -> Path -> CnvMonad Term
-choices nr path = do (args,_) <- get
-                     let PFCat _ _ schema = args !! nr
-                     descend schema path CNil
-  where
-    descend (CRec rs)     (CProj lbl path) rpath = case lookup lbl rs of
-                                                     Just (Identity t) -> descend t path (CProj lbl rpath)
-    descend (CRec rs)     CNil             rpath = do rs <- mapM (\(lbl,Identity t) -> fmap (assign lbl) (descend t CNil (CProj lbl rpath))) rs
-                                                      return (R rs)
-    descend (CTbl pt cs)  (CSel  trm path) rpath = case lookup trm cs of
-                                                     Just (Identity t) -> descend t path (CSel trm rpath)
-    descend (CTbl pt cs)  CNil             rpath = do cs <- mapM (\(trm,Identity t) -> descend t CNil (CSel trm rpath)) cs
-                                                      return (V pt cs)
-    descend (CPar (m,vs)) CNil             rpath = case vs of
-                                                     [(value,index)] -> return value
-                                                     values          -> let path = reversePath rpath
-                                                                        in CM (\gr c s -> Case nr path [(value, updateEnv path value gr c s)
-                                                                                                                    | (value,index) <- values])
-    descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)
-
-    updateEnv path value gr c (args,seq) =
-      case updateNthM (restrictProtoFCat path value) nr args of
-        Just args -> c value (args,seq)
-        Nothing   -> bug "conflict in updateEnv"
-
--- | the argument should be a parameter type and then
--- the function returns all possible values.
-getAllParamValues :: Type -> CnvMonad [Term]
-getAllParamValues ty = CM (\gr c -> c (err bug id (allParamValues gr ty)))
-
-mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
-mkRecord xs = CM (\gr c -> foldl (\c (lbl,CM m) bs s -> c ((lbl,m gr (\v s -> Return v) s) : bs) s) (c . CRec) xs [])
-
-mkTable  :: Type -> [(Term ,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
-mkTable pt xs = CM (\gr c -> foldl (\c (trm,CM m) bs s -> c ((trm,m gr (\v s -> Return v) s) : bs) s) (c . CTbl pt) xs [])
-
-----------------------------------------------------------------------
--- Term Schema
---
--- The term schema is a term-like structure, with records, tables,
--- strings and parameters values, but in addition we could add
--- annotations of arbitrary types
-
--- | Term schema
-data Schema b s c
-  = CRec      [(Label,b (Schema b s c))]
-  | CTbl Type [(Term, b (Schema b s c))]
-  | CStr s
-  | CPar c
---deriving Show -- doesn't work
-
-instance Show s => Show (Schema b s c) where
-  showsPrec _ sch =
-      case sch of
-        CRec r   -> showString "CRec " . shows (map fst r)
-        CTbl t _ -> showString "CTbl " . showsPrec 10 t . showString " _"
-        CStr s   -> showString "CStr " . showsPrec 10 s
-        CPar c   -> showString "CPar{}"
-
--- | Path into a term or term schema
-data Path
-  = CProj Label Path
-  | CSel  Term  Path
-  | CNil
-  deriving (Eq,Show)
-
--- | The ProtoFCat represents a linearization type as term schema.
--- The annotations are as follows: the strings are annotated with
--- their index in the PMCFG tuple, the parameters are annotated
--- with their value both as term and as index.
-data ProtoFCat  = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)]))
-type Env        = (ProtoFCat, [ProtoFCat])
-
-protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
-protoFCat gr cat lincat =
-  case computeCatRange gr lincat of
-    ((_,f),schema) -> PFCat (snd cat) f schema
-
-getFIds :: ProtoFCat -> [FId]
-getFIds (PFCat _ _ schema) =
-  reverse (solutions (variants schema) ())
-  where
-    variants (CRec rs)         = fmap sum $ mapM (\(lbl,Identity t) -> variants t) rs
-    variants (CTbl _ cs)       = fmap sum $ mapM (\(trm,Identity t) -> variants t) cs
-    variants (CStr _)          = return 0
-    variants (CPar (m,values)) = do (value,index) <- member values
-                                    return (m*index)
-
-catFactor :: ProtoFCat -> Int
-catFactor (PFCat _ f _) = f
-
-computeCatRange gr lincat = compute (0,1) lincat
-  where
-    compute st (RecType  rs) = let (st',rs') = List.mapAccumL (\st (lbl,t) -> case lbl of
-                                                                                LVar _ -> let (st',t') = compute st t
-                                                                                          in (st ,(lbl,Identity t'))
-                                                                                _      -> let (st',t') = compute st t
-                                                                                          in (st',(lbl,Identity t'))) st rs
-                               in (st',CRec rs')
-    compute st (Table pt vt) = let vs        = err bug id (allParamValues gr pt)
-                                   (st',cs') = List.mapAccumL (\st v       -> let (st',vt') = compute st vt
-                                                                              in (st',(v,Identity vt'))) st vs
-                               in (st',CTbl pt cs')
-    compute st (Sort s)
-                   | s == cStr = let (index,m) = st
-                                 in ((index+1,m),CStr index)
-    compute st t               = let vs = err bug id (allParamValues gr t)
-                                     (index,m) = st
-                                 in ((index,m*length vs),CPar (m,zip vs [0..]))
-
-ppPath (CProj lbl path) = lbl <+> ppPath path
-ppPath (CSel  trm path) = ppU 5 trm   <+> ppPath path
-ppPath CNil             = empty
-
-reversePath path = rev CNil path
-  where
-    rev path0 CNil             = path0
-    rev path0 (CProj lbl path) = rev (CProj lbl path0) path
-    rev path0 (CSel  trm path) = rev (CSel  trm path0) path
-
-
-----------------------------------------------------------------------
--- term conversion
-
-type Value a = Schema Branch a Term
-
-convertTerm :: Options -> Path -> Type -> Term -> CnvMonad (Value [Symbol])
-convertTerm opts sel ctype (Vr x)       = convertArg opts ctype (getVarIndex x) (reversePath sel)
-convertTerm opts sel ctype (Abs _ _ t)  = convertTerm opts sel ctype t                -- there are only top-level abstractions and we ignore them !!!
-convertTerm opts sel ctype (R record)   = convertRec opts sel ctype record
-convertTerm opts sel ctype (P term l)   = convertTerm opts (CProj l sel) ctype term
-convertTerm opts sel ctype (V pt ts)    = convertTbl opts sel ctype pt ts
-convertTerm opts sel ctype (S term p)   = do v <- evalTerm CNil p
-                                             convertTerm opts (CSel v sel) ctype term
-convertTerm opts sel ctype (FV vars)    = do term <- variants vars
-                                             convertTerm opts sel ctype term
-convertTerm opts sel ctype (C t1 t2)    = do v1 <- convertTerm opts sel ctype t1
-                                             v2 <- convertTerm opts sel ctype t2
-                                             return (CStr (concat [s | CStr s <- [v1,v2]]))
-convertTerm opts sel ctype (K t)        = return (CStr [SymKS t])
-convertTerm opts sel ctype Empty        = return (CStr [])
-convertTerm opts sel ctype (Alts s alts)= do CStr s <- convertTerm opts CNil ctype s
-                                             alts <- forM alts $ \(u,alt) -> do
-                                                            CStr u <- convertTerm opts CNil ctype u
-                                                            Strs ps <- unPatt alt
-                                                            ps     <- mapM (convertTerm opts CNil ctype) ps
-                                                            return (u,map unSym ps)
-                                             return (CStr [SymKP s alts])
-  where
-    unSym (CStr [])        = ""
-    unSym (CStr [SymKS t]) = t
-    unSym _                = ppbug $ hang ("invalid prefix in pre expression:") 4 (Alts s alts)
-
-    unPatt (EPatt p) = fmap Strs (getPatts p)
-    unPatt u         = return u
-
-    getPatts p = case p of
-      PAlt a b  -> liftM2 (++) (getPatts a) (getPatts b)
-      PString s -> return [K s]
-      PSeq a b  -> do
-        as <- getPatts a
-        bs <- getPatts b
-        return [K (s ++ t) | K s <- as, K t <- bs]
-      _ -> fail (render ("not valid pattern in pre expression" <+> ppPatt Unqualified 0 p))
-
-convertTerm opts sel ctype (Q (m,f))
-  | m == cPredef &&
-    f == cBIND                          = return (CStr [SymBIND])
-  | m == cPredef &&
-    f == cSOFT_BIND                     = return (CStr [SymSOFT_BIND])
-  | m == cPredef &&
-    f == cSOFT_SPACE                    = return (CStr [SymSOFT_SPACE])
-  | m == cPredef &&
-    f == cCAPIT                         = return (CStr [SymCAPIT])
-  | m == cPredef &&
-    f == cALL_CAPIT                     = return (CStr [SymALL_CAPIT])
-  | m == cPredef &&
-    f == cNonExist                      = return (CStr [SymNE])
-{-
-convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2))
-                    | l `elem` map fst rs2 = convertTerm opts sel ctype t2
-                    | otherwise            = convertTerm opts sel ctype t1
-
-convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2)
-                    | l `elem` map fst rs1 = convertTerm opts sel ctype t1
-                    | otherwise            = convertTerm opts sel ctype t2
--}
-convertTerm opts CNil ctype t           = do v <- evalTerm CNil t
-                                             return (CPar v)
-convertTerm _    sel  _     t           = ppbug ("convertTerm" <+> sep [parens (show sel),ppU 10 t])
-
-convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
-convertArg opts (RecType rs)  nr path =
-  mkRecord (map (\(lbl,ctype) -> (lbl,convertArg opts ctype nr (CProj lbl path))) rs)
-convertArg opts (Table pt vt) nr path = do
-  vs <- getAllParamValues pt
-  mkTable pt (map (\v -> (v,convertArg opts vt nr (CSel v path))) vs)
-convertArg opts (Sort _)      nr path = do
-  (args,_) <- get
-  let PFCat cat _ schema = args !! nr
-      l = index (reversePath path) schema
-      sym | CProj (LVar i) CNil <- path = SymVar nr i
-          | isLiteralCat opts cat       = SymLit nr l
-          | otherwise                   = SymCat nr l
-  return (CStr [sym])
-  where
-    index (CProj lbl path) (CRec   rs) = case lookup lbl rs of
-                                           Just (Identity t) -> index path t
-    index (CSel  trm path) (CTbl _ rs) = case lookup trm rs of
-                                           Just (Identity t) -> index path t
-    index CNil             (CStr idx)  = idx
-convertArg opts ty nr path              = do
-  value <- choices nr (reversePath path)
-  return (CPar value)
-
-convertRec opts CNil (RecType rs) record =
-    mkRecord [(lbl,convertTerm opts CNil ctype (proj lbl))|(lbl,ctype)<-rs]
-  where proj lbl = if isLockLabel lbl then R [] else projectRec lbl record
-convertRec opts (CProj lbl path) ctype record =
-  convertTerm opts path ctype (projectRec lbl record)
-convertRec opts _ ctype _ = bug ("convertRec: "++show ctype)
-
-convertTbl opts CNil (Table _ vt) pt ts = do
-  vs <- getAllParamValues pt
-  mkTable pt (zipWith (\v t -> (v,convertTerm opts CNil vt t)) vs ts)
-convertTbl opts (CSel v sub_sel) ctype pt ts = do
-  vs <- getAllParamValues pt
-  case lookup v (zip vs ts) of
-    Just t  -> convertTerm opts sub_sel ctype t
-    Nothing -> ppbug ( "convertTbl:" <+> ("missing value" <+> v $$
-                                          "among" <+> vcat vs))
-convertTbl opts _ ctype _ _ = bug ("convertTbl: "++show ctype)
-
-
-goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
-goB (Case nr path bs) rpath ss = do (value,b) <- member bs
-                                    restrictArg nr path value
-                                    goB b rpath ss
-goB (Variant bs)      rpath ss = do b <- member bs
-                                    goB b rpath ss
-goB (Return  v)       rpath ss = goV v rpath ss
-
-goV :: Value SeqId -> Path -> [SeqId] -> BacktrackM Env [SeqId]
-goV (CRec xs)    rpath ss = foldM (\ss (lbl,b) -> goB b (CProj lbl rpath) ss) ss (reverse xs)
-goV (CTbl _ xs)  rpath ss = foldM (\ss (trm,b) -> goB b (CSel  trm rpath) ss) ss (reverse xs)
-goV (CStr seqid) rpath ss = return (seqid : ss)
-goV (CPar t)     rpath ss = restrictHead (reversePath rpath) t >> return ss
-
-
-----------------------------------------------------------------------
--- SeqSet
-
-type SeqSet   = Map.Map Sequence SeqId
-
-addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
-addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                       in (seqs',(trm,b'))) seqs bs
-                                       in (seqs1,Case nr path bs1)
-addSequencesB seqs (Variant bs)      = let !(seqs1,bs1) = mapAccumL' addSequencesB seqs bs
-                                       in (seqs1,Variant bs1)
-addSequencesB seqs (Return  v)       = let !(seqs1,v1) = addSequencesV seqs v
-                                       in (seqs1,Return v1)
-
-addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
-addSequencesV seqs (CRec vs)  = let !(seqs1,vs1) = mapAccumL' (\seqs (lbl,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                in (seqs',(lbl,b'))) seqs vs
-                                in (seqs1,CRec vs1)
-addSequencesV seqs (CTbl pt vs)=let !(seqs1,vs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
-                                                                                in (seqs',(trm,b'))) seqs vs
-                                in (seqs1,CTbl pt vs1)
-addSequencesV seqs (CStr lin) = let !(seqs1,seqid) = addSequence seqs lin
-                                in (seqs1,CStr seqid)
-addSequencesV seqs (CPar i)   = (seqs,CPar i)
-
--- a strict version of Data.List.mapAccumL
-mapAccumL' f s []     = (s,[])
-mapAccumL' f s (x:xs) = (s'',y:ys)
-                        where !(s', y ) = f s x
-                              !(s'',ys) = mapAccumL' f s' xs
-
-addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
-addSequence seqs lst =
-  case Map.lookup seq seqs of
-    Just id -> (seqs,id)
-    Nothing -> let !last_seq = Map.size seqs
-               in (Map.insert seq last_seq seqs, last_seq)
-  where
-    seq = mkArray lst
-
-
-------------------------------------------------------------
--- eval a term to ground terms
-
-evalTerm :: Path -> Term -> CnvMonad Term
-evalTerm CNil (QC f)       = return (QC f)
-evalTerm CNil (App x y)    = do x <- evalTerm CNil x
-                                y <- evalTerm CNil y
-                                return (App x y)
-evalTerm path (Vr x)       = choices (getVarIndex x) path
-evalTerm path (R rs)       =
-    case path of
-      CProj lbl path -> evalTerm path (projectRec lbl rs)
-      CNil           -> R `fmap` mapM (\(lbl,(_,t)) -> assign lbl `fmap` evalTerm path t) rs
-evalTerm path (P term lbl) = evalTerm (CProj lbl path) term
-evalTerm path (V pt ts)    =
-   case path of
-     CNil          -> V pt `fmap` mapM (evalTerm path) ts
-     CSel trm path ->
-         do vs <- getAllParamValues pt
-            case lookup trm (zip vs ts) of
-              Just t  -> evalTerm path t
-              Nothing -> ppbug $ "evalTerm: missing value:"<+>trm
-                                 $$ "among:" <+>fsep (map (ppU 10) vs)
-evalTerm path (S term sel) = do v <- evalTerm CNil sel
-                                evalTerm (CSel v path) term
-evalTerm path (FV terms)   = variants terms >>= evalTerm path
-evalTerm path (EInt n)     = return (EInt n)
-evalTerm path t            = ppbug ("evalTerm" <+> parens t)
---evalTerm path t            = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])
-
-getVarIndex x = maybe err id $ getArgIndex x
-  where err = bug ("getVarIndex "++show x)
-
-----------------------------------------------------------------------
--- GrammarEnv
-
-data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
-type ProdSet  = Set.Set Production
-type FunSet   = Map.Map (UArray LIndex SeqId) FunId
-
-emptyPMCFGEnv =
-  PMCFGEnv Set.empty Map.empty
-
-addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
-addFunction (PMCFGEnv prodSet funSet) !fid fun args =
-  case Map.lookup fun funSet of
-    Just !funid -> PMCFGEnv (Set.insert (Production fid funid args) prodSet)
-                            funSet
-    Nothing     -> let !funid = Map.size funSet
-                   in PMCFGEnv (Set.insert (Production fid funid args) prodSet)
-                               (Map.insert fun funid funSet)
-
-getPMCFG :: PMCFGEnv -> PMCFG
-getPMCFG (PMCFGEnv prodSet funSet) =
-  PMCFG (optimize prodSet) (mkSetArray funSet)
-  where
-    optimize ps = Map.foldrWithKey ff [] (Map.fromListWith (++) [((fid,funid),[args]) | (Production fid funid args) <- Set.toList ps])
-      where
-        ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
-        ff (fid,funid) xs prods
-          | product (map IntSet.size ys) == count
-                      = (Production fid funid (map IntSet.toList ys)) : prods
-          | otherwise = map (Production fid funid) xs ++ prods
-          where
-            count = sum (map (product . map length) xs)
-            ys    = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
-
-------------------------------------------------------------
--- updating the MCF rule
-
-restrictArg :: LIndex -> Path -> Term -> BacktrackM Env ()
-restrictArg nr path index = do
-  (head, args) <- get
-  args <- updateNthM (restrictProtoFCat path index) nr args
-  put (head, args)
-
-restrictHead :: Path -> Term -> BacktrackM Env ()
-restrictHead path term = do
-  (head, args) <- get
-  head <- restrictProtoFCat path term head
-  put (head, args)
-
-restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
-restrictProtoFCat path v (PFCat cat f schema) = do
-  schema <- addConstraint path v schema
-  return (PFCat cat f schema)
-  where
-    addConstraint (CProj lbl path) v (CRec rs)     = fmap CRec      $ update lbl (addConstraint path v) rs
-    addConstraint (CSel  trm path) v (CTbl pt cs)  = fmap (CTbl pt) $ update trm (addConstraint path v) cs
-    addConstraint CNil             v (CPar (m,vs)) = case lookup v vs of
-                                                       Just index -> return (CPar (m,[(v,index)]))
-                                                       Nothing    -> mzero
-    addConstraint CNil             v (CStr _)      = bug "restrictProtoFCat: string path"
-
-    update k0 f [] = return []
-    update k0 f (x@(k,Identity v):xs)
-      | k0 == k    = do v <- f v
-                        return ((k,Identity v):xs)
-      | otherwise  = do xs <- update k0 f xs
-                        return (x:xs)
-
-mkArray    lst = listArray (0,length lst-1) lst
-mkSetArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]
-
-bug msg = ppbug msg
-ppbug msg = error completeMsg
- where
-  originalMsg = render $ hang "Internal error in GeneratePMCFG:" 4 msg
-  completeMsg =
-    case render msg of -- the error message for pattern matching a runtime string
-      "descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)"
-        -> unlines [originalMsg -- add more helpful output
-            ,""
-            ,"1) Check that you are not trying to pattern match a /runtime string/."
-            ,"   These are illegal:"
-            ,"     lin Test foo = case foo.s of {"
-            ,"                       \"str\" => … } ;   <- explicit matching argument of a lin"
-            ,"     lin Test foo = opThatMatches foo   <- calling an oper that pattern matches"
-            ,""
-            ,"2) Not about pattern matching? Submit a bug report and we update the error message."
-            ,"     https://github.com/GrammaticalFramework/gf-core/issues"
-            ]
-      _ -> originalMsg -- any other message: just print it as is
-
-ppU = ppTerm Unqualified

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -1,439 +0,0 @@
--- | Translate grammars to Canonical form
--- (a common intermediate representation to simplify export to other formats)
-module GF.Compile.GrammarToCanonical(
-       grammar2canonical,abstract2canonical,concretes2canonical,
-       projection,selection
-       ) where
-import Data.List(nub,partition)
-import qualified Data.Map as M
-import Data.Maybe(fromMaybe)
-import qualified Data.Set as S
-import GF.Data.ErrM
-import GF.Text.Pretty
-import GF.Grammar.Grammar as G
-import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
-import GF.Grammar.Lockfield(isLockLabel)
-import GF.Grammar.Predef(cPredef,cInts)
-import GF.Compile.Compute.Predef(predef)
-import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
-import GF.Infra.Option(Options,optionsPGF)
-import PGF.Internal(Literal(..))
-import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
-import GF.Grammar.Canonical as C
-import System.FilePath ((</>), (<.>))
-import qualified Debug.Trace as T
-
-
--- | Generate Canonical code for the named abstract syntax and all associated
--- concrete syntaxes
-grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
-grammar2canonical opts absname gr =
-   Grammar (abstract2canonical absname gr)
-           (map snd (concretes2canonical opts absname gr))
-
--- | Generate Canonical code for the named abstract syntax
-abstract2canonical :: ModuleName -> G.Grammar -> Abstract
-abstract2canonical absname gr =
-    Abstract (modId absname) (convFlags gr absname) cats funs
-  where
-    cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
-
-    funs = [FunDef (gId f) (convType ty) |
-            ((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
-
-    adefs = allOrigInfos gr absname
-
-    convCtx = maybe [] (map convHypo . unLoc)
-    convHypo (bt,name,t) =
-      case typeForm t of
-        ([],(_,cat),[]) -> gId cat -- !!
-        tf -> error $ "abstract2canonical convHypo: " ++ show tf
-
-    convType t =
-      case typeForm t of
-        (hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
-          where
-            bs = map convHypo' hyps
-            as = map convType args
-
-    convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
-
--- | Generate Canonical code for the all concrete syntaxes associated with
--- the named abstract syntax in given the grammar.
-concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
-concretes2canonical opts absname gr =
-  [(cncname,concrete2canonical gr cenv absname cnc cncmod)
-     | let cenv = resourceValues opts gr,
-       cnc<-allConcretes gr absname,
-       let cncname = "canonical" </> render cnc <.> "gf"
-           Ok cncmod = lookupModule gr cnc
-  ]
-
--- | Generate Canonical GF for the given concrete module.
-concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
-concrete2canonical gr cenv absname cnc modinfo =
-  Concrete (modId cnc) (modId absname) (convFlags gr cnc)
-      (neededParamTypes S.empty (params defs))
-      [lincat | (_,Left lincat) <- defs]
-      [lin | (_,Right lin) <- defs]
-  where
-    defs = concatMap (toCanonical gr absname cenv) .
-           M.toList $
-           jments modinfo
-
-    params = S.toList . S.unions . map fst
-
-    neededParamTypes have [] = []
-    neededParamTypes have (q:qs) =
-        if q `S.member` have
-        then neededParamTypes have qs
-        else let ((got,need),def) = paramType gr q
-             in def++neededParamTypes (S.union got have) (S.toList need++qs)
-
-toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
-toCanonical gr absname cenv (name,jment) =
-  case jment of
-    CncCat (Just (L loc typ)) _ _ pprn _ ->
-        [(pts,Left (LincatDef (gId name) (convType ntyp)))]
-      where
-        pts = paramTypes gr ntyp
-        ntyp = nf loc typ
-    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
-        [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
-      where
-        tts = tableTypes gr [e']
-
-        e' = cleanupRecordFields lincat $
-             unAbs (length params) $
-             nf loc (mkAbs params (mkApp def (map Vr args)))
-        params = [(b,x)|(b,x,_)<-ctx]
-        args = map snd params
-
-    AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
-                     Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
-                     _ -> []
-    _ -> []
-  where
-    nf loc = normalForm cenv (L loc name)
-
-    unAbs 0 t = t
-    unAbs n (Abs _ _ t) = unAbs (n-1) t
-    unAbs _ t = t
-
-tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
-tableTypes gr ts = S.unions (map tabtys ts)
-  where
-    tabtys t =
-      case t of
-        V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
-        T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
-        _ -> collectOp tabtys t
-
-paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
-paramTypes gr t =
-  case t of
-    RecType fs -> S.unions (map (paramTypes gr.snd) fs)
-    Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
-    App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
-    Sort _ -> S.empty
-    EInt _ -> S.empty
-    Q q -> lookup q
-    QC q -> lookup q
-    FV ts -> S.unions (map (paramTypes gr) ts)
-    _ -> ignore
-  where
-    lookup q = case lookupOrigInfo gr q of
-                 Ok (_,ResOper  _ (Just (L _ t))) ->
-                                       S.insert q (paramTypes gr t)
-                 Ok (_,ResParam {}) -> S.singleton q
-                 _ -> ignore
-
-    ignore = T.trace ("Ignore: " ++ show t) S.empty
-
--- | Filter out record fields from definitions which don't appear in lincat.
-cleanupRecordFields :: G.Type -> Term -> Term
-cleanupRecordFields (RecType ls) (R as) =
-  let defnFields = M.fromList ls
-  in R
-      [ (lbl, (mty, t'))
-      | (lbl, (mty, t)) <- as
-      , M.member lbl defnFields
-      , let Just ty = M.lookup lbl defnFields
-      , let t' = cleanupRecordFields ty t
-      ]
-cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
-cleanupRecordFields _ t = t
-
-convert :: G.Grammar -> Term -> LinValue
-convert gr = convert' gr []
-
-convert' :: G.Grammar -> [Ident] -> Term -> LinValue
-convert' gr vs = ppT
-  where
-    ppT0 = convert' gr vs
-    ppTv vs' = convert' gr vs'
-
-    ppT t =
-      case t of
---      Abs b x t -> ...
---      V ty ts -> VTableValue (convType ty) (map ppT ts)
-        V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
-          where
-            Ok pts = allParamValues gr ty
-            Ok ps = mapM term2patt pts
-        T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
-        S t p -> selection (ppT t) (ppT p)
-        C t1 t2 -> concatValue (ppT t1) (ppT t2)
-        App f a -> ap (ppT f) (ppT a)
-        R r -> RecordValue (fields (sortRec r))
-        P t l -> projection (ppT t) (lblId l)
-        Vr x -> VarValue (gId x)
-        Cn x -> VarValue (gId x) -- hmm
-        Con c -> ParamConstant (Param (gId c) [])
-        Sort k -> VarValue (gId k)
-        EInt n -> LiteralValue (IntConstant n)
-        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
-        QC (m,n) -> ParamConstant (Param (gQId m n) [])
-        K s -> LiteralValue (StrConstant s)
-        Empty -> LiteralValue (StrConstant "")
-        FV ts -> VariantValue (map ppT ts)
-        Alts t' vs -> alts vs (ppT t')
-        _ -> error $ "convert' ppT: " ++ show t
-
-    ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
-
-    ppPredef n =
-      case predef n of
-        Ok BIND       -> p "BIND"
-        Ok SOFT_BIND  -> p "SOFT_BIND"
-        Ok SOFT_SPACE -> p "SOFT_SPACE"
-        Ok CAPIT      -> p "CAPIT"
-        Ok ALL_CAPIT  -> p "ALL_CAPIT"
-        _ -> VarValue (gQId cPredef n) -- hmm
-      where
-       p = PredefValue . PredefId . rawIdentS
-
-    ppP p =
-      case p of
-        PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
-        PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
-        PR r -> RecordPattern (fields r) {-
-        PW -> WildPattern
-        PV x -> VarP x
-        PString s -> Lit (show s) -- !!
-        PInt i -> Lit (show i)
-        PFloat x -> Lit (show x)
-        PT _ p -> ppP p
-        PAs x p -> AsP x (ppP p) -}
-        _ -> error $ "convert' ppP: " ++ show p
-      where
-        fields = map field . filter (not.isLockLabel.fst)
-        field (l,p) = RecordRow (lblId l) (ppP p)
-
---  patToParam p = case ppP p of ParamPattern pv -> pv
-
---  token s = single (c "TK" `Ap` lit s)
-
-    alts vs = PreValue (map alt vs)
-      where
-        alt (t,p) = (pre p,ppT0 t)
-
-        pre (K s) = [s]
-        pre Empty = [""]  -- Empty == K ""
-        pre (Strs ts) = concatMap pre ts
-        pre (EPatt p) = pat p
-        pre t = error $ "convert' alts pre: " ++ show t
-
-        pat (PString s) = [s]
-        pat (PAlt p1 p2) = pat p1++pat p2
-        pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
-        pat p = error $ "convert' alts pat: "++show p
-
-    fields = map field . filter (not.isLockLabel.fst)
-    field (l,(_,t)) = RecordRow (lblId l) (ppT t)
-  --c = Const
-  --c = VarValue . VarValueId
-  --lit s = c (show s) -- hmm
-
-    ap f a = case f of
-               ParamConstant (Param p ps) ->
-                 ParamConstant (Param p (ps++[a]))
-               _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
-
-concatValue :: LinValue -> LinValue -> LinValue
-concatValue v1 v2 =
-  case (v1,v2) of
-    (LiteralValue (StrConstant ""),_) -> v2
-    (_,LiteralValue (StrConstant "")) -> v1
-    _ -> ConcatValue v1 v2
-
--- | Smart constructor for projections
-projection :: LinValue -> LabelId -> LinValue
-projection r l = fromMaybe (Projection r l) (proj r l)
-
-proj :: LinValue -> LabelId -> Maybe LinValue
-proj r l =
-  case r of
-    RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
-                          [v] -> Just v
-                          _ -> Nothing
-    _ -> Nothing
-
--- | Smart constructor for selections
-selection :: LinValue -> LinValue -> LinValue
-selection t v =
-  -- Note: impossible cases can become possible after grammar transformation
-  case t of
-    TableValue tt r ->
-        case nub [rv | TableRow _ rv <- keep] of
-          [rv] -> rv
-          _ -> Selection (TableValue tt r') v
-      where
-        -- Don't introduce wildcard patterns, true to the canonical format,
-        -- annotate (or eliminate) rhs in impossible rows
-        r' = map trunc r
-        trunc r@(TableRow p e) = if mightMatchRow v r
-                                 then r
-                                 else TableRow p (impossible e)
-        {-
-        -- Creates smaller tables, but introduces wildcard patterns
-        r' = if null discard
-             then r
-             else keep++[TableRow WildPattern impossible]
-        -}
-        (keep,discard) = partition (mightMatchRow v) r
-    _ -> Selection t v
-
-impossible :: LinValue -> LinValue
-impossible = CommentedValue "impossible"
-
-mightMatchRow :: LinValue -> TableRow rhs -> Bool
-mightMatchRow v (TableRow p _) =
-  case p of
-    WildPattern -> True
-    _ -> mightMatch v p
-
-mightMatch :: LinValue -> LinPattern -> Bool
-mightMatch v p =
-  case v of
-    ConcatValue _ _ -> False
-    ParamConstant (Param c1 pvs) ->
-      case p of
-        ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
-                                       and [mightMatch v p|(v,p)<-zip pvs pps]
-        _ -> False
-    RecordValue rv ->
-      case p of
-        RecordPattern rp ->
-          and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
-        _ -> False
-    _ -> True
-
-patVars :: Patt -> [Ident]
-patVars p =
-  case p of
-    PV x -> [x]
-    PAs x p -> x:patVars p
-    _ -> collectPattOp patVars p
-
-convType :: Term -> LinType
-convType = ppT
-  where
-    ppT t =
-      case t of
-        Table ti tv -> TableType (ppT ti) (ppT tv)
-        RecType rt -> RecordType (convFields rt)
---      App tf ta -> TAp (ppT tf) (ppT ta)
---      FV [] -> tcon0 (identS "({-empty variant-})")
-        Sort k -> convSort k
---      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
-        FV (t:ts) -> ppT t -- !!
-        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
-        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
-        _ -> error $ "convType ppT: " ++ show t
-
-    convFields = map convField . filter (not.isLockLabel.fst)
-    convField (l,r) = RecordRow (lblId l) (ppT r)
-
-    convSort k = case showIdent k of
-                   "Float" -> FloatType
-                   "Int" -> IntType
-                   "Str" -> StrType
-                   _ -> error $ "convType convSort: " ++ show k
-
-toParamType :: Term -> ParamType
-toParamType t = case convType t of
-                  ParamType pt -> pt
-                  _ -> error $ "toParamType: " ++ show t
-
-toParamId :: Term -> ParamId
-toParamId t = case toParamType t of
-                   ParamTypeId p -> p
-
-paramType :: G.Grammar
-             -> (ModuleName, Ident)
-             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
-paramType gr q@(_,n) =
-    case lookupOrigInfo gr q of
-      Ok (m,ResParam (Just (L _ ps)) _)
-       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
-         ((S.singleton (m,n),argTypes ps),
-          [ParamDef name (map (param m) ps)]
-         )
-       where name = gQId m n
-      Ok (m,ResOper  _ (Just (L _ t)))
-        | m==cPredef && n==cInts ->
-           ((S.empty,S.empty),[]) {-
-           ((S.singleton (m,n),S.empty),
-            [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
-        | otherwise ->
-           ((S.singleton (m,n),paramTypes gr t),
-            [ParamAliasDef (gQId m n) (convType t)])
-      _ -> ((S.empty,S.empty),[])
-  where
-    param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
-    argTypes = S.unions . map argTypes1
-    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
-
-lblId :: Label -> C.LabelId
-lblId (LIdent ri) = LabelId ri
-lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
-
-modId :: ModuleName -> C.ModId
-modId (MN m) = ModId (ident2raw m)
-
-class FromIdent i where
-  gId :: Ident -> i
-
-instance FromIdent VarId where
-  gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
-
-instance FromIdent C.FunId where gId = C.FunId . ident2raw
-instance FromIdent CatId where gId = CatId . ident2raw
-instance FromIdent ParamId where gId = ParamId . unqual
-instance FromIdent VarValueId where gId = VarValueId . unqual
-
-class FromIdent i => QualIdent i where
-  gQId :: ModuleName -> Ident -> i
-
-instance QualIdent ParamId where gQId m n = ParamId (qual m n)
-instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
-
-qual :: ModuleName -> Ident -> QualId
-qual m n = Qual (modId m) (ident2raw n)
-
-unqual :: Ident -> QualId
-unqual n = Unqual (ident2raw n)
-
-convFlags :: G.Grammar -> ModuleName -> Flags
-convFlags gr mn =
-  Flags [(rawIdentS n,convLit v) |
-         (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
-  where
-    convLit l =
-      case l of
-        LStr s -> Str s
-        LInt i -> C.Int i
-        LFlt d -> Flt d

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -1,308 +0,0 @@
-{-# LANGUAGE BangPatterns, FlexibleContexts #-}
-module GF.Compile.GrammarToPGF (mkCanon2pgf) where
-
---import GF.Compile.Export
-import GF.Compile.GeneratePMCFG
-import GF.Compile.GenerateBC
-
-import PGF(CId,mkCId,utf8CId)
-import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
-import PGF.Internal(updateProductionIndices)
-import qualified PGF.Internal as C
-import qualified PGF.Internal as D
-import GF.Grammar.Predef
-import GF.Grammar.Grammar
-import qualified GF.Grammar.Lookup as Look
-import qualified GF.Grammar as A
-import qualified GF.Grammar.Macros as GM
-
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Infra.UseIO (IOE)
-import GF.Data.Operations
-
-import Data.List
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
-import Data.Array.IArray
-
-
-mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
-mkCanon2pgf opts gr am = do
-  (an,abs) <- mkAbstr am
-  cncs     <- mapM mkConcr (allConcretes gr am)
-  return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
-  where
-    cenv = resourceValues opts gr
-
-    mkAbstr am = return (mi2i am, D.Abstr flags funs cats)
-      where
-        aflags = err (const noOptions) mflags (lookupModule gr am)
-
-        adefs =
-            [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
-            Look.allOrigInfos gr am
-
-        flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF aflags]
-
-        funs = Map.fromList [(i2i f, (mkType [] ty, arity, mkDef gr arity mdef, 0)) | 
-                                   ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
-                                   let arity = mkArity ma mdef ty]
-
-        cats = Map.fromList [(i2i c, (snd (mkContext [] cont),catfuns c, 0)) |
-                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs]
-
-        catfuns cat =
-              [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True)) <- adefs, snd (GM.valCat ty) == cat]
-
-    mkConcr cm = do
-      let cflags = err (const noOptions) mflags (lookupModule gr cm)
-          ciCmp | flag optCaseSensitive cflags = compare
-                | otherwise                    = C.compareCaseInsensitve
-
-      (ex_seqs,cdefs) <- addMissingPMCFGs
-                            Map.empty 
-                            ([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
-                             Look.allOrigInfos gr cm)
-
-      let flags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF cflags]
-
-          seqs = (mkArray . C.sortNubBy ciCmp . concat) $
-                     (Map.keys ex_seqs : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
-
-          ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
-
-          !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
-          !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
-                                = genCncFuns gr am cm ex_seqs_arr ciCmp seqs cdefs fid_cnt1 cnccats
-
-          printnames = genPrintNames cdefs
-      return (mi2i cm, D.Concr flags
-                              printnames
-                              cncfuns
-                              lindefs
-                              linrefs
-                              seqs
-                              productions
-                              IntMap.empty
-                              Map.empty
-                              cnccats
-                              IntMap.empty
-                              fid_cnt2)
-      where
-        -- if some module was compiled with -no-pmcfg, then
-        -- we have to create the PMCFG code just before linking
-        addMissingPMCFGs seqs []                  = return (seqs,[])
-        addMissingPMCFGs seqs (((m,id), info):is) = do
-          (seqs,info) <- addPMCFG opts gr cenv Nothing am cm seqs id info
-          (seqs,is  ) <- addMissingPMCFGs seqs is
-          return (seqs, ((m,id), info) : is)
-
-i2i :: Ident -> CId
-i2i = utf8CId . ident2utf8
-
-mi2i :: ModuleName -> CId
-mi2i (MN i) = i2i i
-
-mkType :: [Ident] -> A.Type -> C.Type
-mkType scope t =
-  case GM.typeForm t of
-    (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
-                           in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
-
-mkExp :: [Ident] -> A.Term -> C.Expr
-mkExp scope t = 
-  case t of
-    Q (_,c)  -> C.EFun (i2i c)
-    QC (_,c) -> C.EFun (i2i c)
-    Vr x     -> case lookup x (zip scope [0..]) of
-                  Just i  -> C.EVar  i
-                  Nothing -> C.EMeta 0
-    Abs b x t-> C.EAbs b (i2i x) (mkExp (x:scope) t)
-    App t1 t2-> C.EApp (mkExp scope t1) (mkExp scope t2)
-    EInt i   -> C.ELit (C.LInt (fromIntegral i))
-    EFloat f -> C.ELit (C.LFlt f)
-    K s      -> C.ELit (C.LStr s)
-    Meta i   -> C.EMeta i
-    _        -> C.EMeta 0
-
-mkPatt scope p = 
-  case p of
-    A.PP (_,c) ps->let (scope',ps') = mapAccumL mkPatt scope ps
-                   in (scope',C.PApp (i2i c) ps')
-    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))
-    A.PImplArg p-> let (scope',p') = mkPatt scope p
-                   in (scope',C.PImplArg p')
-    A.PTilde t  -> (  scope,C.PTilde (mkExp scope t))
-
-mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
-mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty
-                                                      in if x == identW
-                                                           then (  scope,(bt,i2i x,ty'))
-                                                           else (x:scope,(bt,i2i x,ty'))) scope hyps 
-
-mkDef gr arity (Just eqs) = Just ([C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
-                                 ,generateByteCode gr arity eqs
-                                 )
-mkDef gr arity Nothing    = Nothing
-
-mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
-mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
-mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
-                               in length ctxt
-
-genCncCats gr am cm cdefs =
-  let (index,cats) = mkCncCats 0 cdefs
-  in (index, Map.fromList cats)
-  where
-    mkCncCats index []                                                = (index,[])
-    mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs) 
-      | id == cInt    = 
-            let cc            = pgfCncCat gr lincat fidInt
-                (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
-      | id == cFloat  = 
-            let cc            = pgfCncCat gr lincat fidFloat
-                (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
-      | id == cString = 
-            let cc            = pgfCncCat gr lincat fidString
-                (index',cats) = mkCncCats index cdefs
-            in (index', (i2i id,cc) : cats)
-      | otherwise     =
-            let cc@(C.CncCat _s e _) = pgfCncCat gr lincat index
-                (index',cats)        = mkCncCats (e+1) cdefs
-            in (index', (i2i id,cc) : cats)
-    mkCncCats index (_                      :cdefs) = mkCncCats index cdefs
-
-genCncFuns :: Grammar
-           -> ModuleName
-           -> ModuleName
-           -> Array SeqId Sequence
-           -> (Sequence -> Sequence -> Ordering)
-           -> Array SeqId Sequence
-           -> [(QIdent, Info)]
-           -> FId
-           -> Map.Map CId D.CncCat
-           -> (FId,
-               IntMap.IntMap (Set.Set D.Production),
-               IntMap.IntMap [FunId],
-               IntMap.IntMap [FunId],
-               Array FunId D.CncFun)
-genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt cnccats =
-  let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt  0 [] IntMap.empty IntMap.empty
-      (fid_cnt2,funs_cnt2,funs2,prods)           = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty
-  in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2)
-  where
-    mkCncCats []                                                        fid_cnt funs_cnt funs lindefs linrefs =
-      (fid_cnt,funs_cnt,funs,lindefs,linrefs)
-    mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs =
-      let !funs_cnt' = let (s_funid, e_funid) = bounds funs0
-                       in funs_cnt+(e_funid-s_funid+1)
-          lindefs'   = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0
-          linrefs'   = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0
-          funs'      = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0)
-      in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs'
-    mkCncCats (_                                                :cdefs) fid_cnt funs_cnt funs lindefs linrefs =
-      mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs
-
-    mkCncFuns []                                                        fid_cnt funs_cnt funs lindefs crc prods =
-      (fid_cnt,funs_cnt,funs,prods)
-    mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods =
-      let ---Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
-          ty_C           = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id)
-          !funs_cnt'     = let (s_funid, e_funid) = bounds funs0
-                           in funs_cnt+(e_funid-s_funid+1)
-          !(fid_cnt',crc',prods') 
-                         = foldl' (toProd lindefs ty_C funs_cnt)
-                                  (fid_cnt,crc,prods) prods0
-          funs'          = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0)
-      in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods'
-    mkCncFuns (_                                                :cdefs) fid_cnt funs_cnt funs lindefs crc prods = 
-      mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods
-
-    toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) =
-      let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) 
-          set0    = Set.fromList (map (C.PApply (offs+funid0)) (sequence args))
-          fid     = mkFId res_C fid0
-          !prods' = case IntMap.lookup fid prods of
-                     Just set -> IntMap.insert fid (Set.union set0 set) prods
-                     Nothing  -> IntMap.insert fid set0 prods
-      in (fid_cnt,crc,prods')
-      where
-        mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) =
-          case fid0s of
-            [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt)
-            fid0s  -> case Map.lookup fids crc of
-                        Just fid -> (st,map (flip C.PArg fid) ctxt)
-                        Nothing  -> let !crc'   = Map.insert fids fid_cnt crc
-                                        !prods' = IntMap.insert fid_cnt (Set.fromList (map C.PCoerce fids)) prods
-                                    in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt)
-          where
-            (hargs_C,arg_C) = GM.catSkeleton ty
-            ctxt = mapM (mkCtxt lindefs) hargs_C
-            fids = map (mkFId arg_C) fid0s
-
-    mkLinDefId id = prefixIdent "lindef " id
-
-    toLinDef res offs lindefs (Production fid0 funid0 args) =
-      if args == [[fidVar]]
-        then IntMap.insertWith (++) fid [offs+funid0] lindefs
-        else lindefs
-      where
-        fid = mkFId res fid0
-
-    toLinRef res offs linrefs (Production fid0 funid0 [fargs]) =
-      if fid0 == fidVar
-        then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids
-        else linrefs
-      where
-        fids = map (mkFId res) fargs
-
-    mkFId (_,cat) fid0 =
-      case Map.lookup (i2i cat) cnccats of
-        Just (C.CncCat s e _) -> s+fid0
-        Nothing               -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat)
-
-    mkCtxt lindefs (_,cat) =
-      case Map.lookup (i2i cat) cnccats of
-        Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]]
-        Nothing               -> error "GrammarToPGF.mkCtxt failed"
-
-    toCncFun offs (m,id) funs (funid0,lins0) =
-      let mseqs = case lookupModule gr m of
-                    Ok (ModInfo{mseqs=Just mseqs}) -> mseqs
-                    _                              -> ex_seqs
-      in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs                                          
-      where
-        newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs)
-
-        binSearch v arr (i,j)
-          | i <= j    = case ciCmp v (arr ! k) of
-                          LT -> binSearch v arr (i,k-1)
-                          EQ -> k
-                          GT -> binSearch v arr (k+1,j)
-          | otherwise = error "binSearch"
-          where
-            k = (i+j) `div` 2
-
-genPrintNames cdefs =
-  Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
-  where
-    prn (CncFun _ _   (Just (L _ tr)) _) = [flatten tr]
-    prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
-    prn _                                = []
-
-    flatten (K s)      = s
-    flatten (Alts x _) = flatten x
-    flatten (C x y)    = flatten x +++ flatten y
-
-mkArray    lst = listArray (0,length lst-1) lst
-mkMapArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map]

src/compiler/GF/Compile/Optimize.hs

@@ -1,232 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------
--- |
--- Module      : Optimize
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/16 13:56:13 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.18 $
---
--- Top-level partial evaluation for GF source modules.
------------------------------------------------------------------------------
-
-module GF.Compile.Optimize (optimizeModule) where
-
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Printer
-import GF.Grammar.Macros
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
-import GF.Data.Operations
-import GF.Infra.Option
-
-import Control.Monad
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import Debug.Trace
-
--- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-
-optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule
-optimizeModule opts sgr m@(name,mi)
-  | mstatus mi == MSComplete = do
-      ids <- topoSortJments m
-      mi <- foldM updateEvalInfo mi ids
-      return (name,mi)
-  | otherwise = return m
- where
-   oopts = opts `addOptions` mflags mi
-
-   resenv = resourceValues oopts sgr
-
-   updateEvalInfo mi (i,info) = do
-     info <- evalInfo oopts resenv sgr (name,mi) i info
-     return (mi{jments=Map.insert i info (jments mi)})
-
-evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
-evalInfo opts resenv sgr m c info = do
-
- (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return ()
-
- errIn ("optimizing " ++ showIdent c) $ case info of
-
-  CncCat ptyp pde pre ppr mpmcfg -> do
-    pde' <- case (ptyp,pde) of
-      (Just (L _ typ), Just (L loc de)) -> do
-        de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
-        return (Just (L loc (factor param c 0 de)))
-      (Just (L loc typ), Nothing) -> do
-        de <- mkLinDefault gr typ
-        de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
-        return (Just (L loc (factor param c 0 de)))
-      _ -> return pde   -- indirection
-
-    pre' <- case (ptyp,pre) of
-      (Just (L _ typ), Just (L loc re)) -> do
-        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
-        return (Just (L loc (factor param c 0 re)))
-      (Just (L loc typ), Nothing) -> do
-        re <- mkLinReference gr typ
-        re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
-        return (Just (L loc (factor param c 0 re)))
-      _ -> return pre   -- indirection
-
-    let ppr' = fmap (evalPrintname resenv c) ppr
-
-    return (CncCat ptyp pde' pre' ppr' mpmcfg)
-
-  CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
-       eIn ("linearization in type" <+> mkProd cont val [] $$ "of function") $ do
-    pde' <- case pde of
-      Just (L loc de) -> do de <- partEval opts gr (cont,val) de
-                            return (Just (L loc (factor param c 0 de)))
-      Nothing -> return pde
-    let ppr' = fmap (evalPrintname resenv c) ppr
-    return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
-{-
-  ResOper pty pde
-    | not new && OptExpand `Set.member` optim -> do
-         pde' <- case pde of
-                   Just (L loc de) -> do de <- computeConcrete gr de
-                                         return (Just (L loc (factor param c 0 de)))
-                   Nothing -> return Nothing
-         return $ ResOper pty pde'
--}
-  _ ->  return info
- where
--- new = flag optNewComp opts -- computations moved to GF.Compile.GeneratePMCFG
-
-   gr = prependModule sgr m
-   optim = flag optOptimizations opts
-   param = OptParametrize `Set.member` optim
-   eIn cat = errIn (render ("Error optimizing" <+> cat <+> c <+> ':'))
-
--- | the main function for compiling linearizations
-partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
-partEval opts = {-if flag optNewComp opts
-                then-} partEvalNew opts
-                {-else partEvalOld opts-}
-
-partEvalNew opts gr (context, val) trm =
-    errIn (render ("partial evaluation" <+> ppTerm Qualified 0 trm)) $
-    checkPredefError trm
-{-
-partEvalOld opts gr (context, val) trm = errIn (render (text "partial evaluation" <+> ppTerm Qualified 0 trm)) $ do
-  let vars  = map (\(bt,x,t) -> x) context
-      args  = map Vr vars
-      subst = [(v, Vr v) | v <- vars]
-      trm1 = mkApp trm args
-  trm2 <- computeTerm gr subst trm1
-  trm3 <- if rightType trm2
-          then computeTerm gr subst trm2 -- compute twice??
-          else recordExpand val trm2 >>= computeTerm gr subst
-  trm4 <- checkPredefError trm3
-  return $ mkAbs [(Explicit,v) | v <- vars] trm4
-  where
-    -- don't eta expand records of right length (correct by type checking)
-    rightType (R rs) = case val of
-                         RecType ts -> length rs == length ts
-                         _          -> False
-    rightType _      = False
-
-
--- here we must be careful not to reduce
---   variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
---   {s  = variants {"Auto" ; "Wagen"} ; g  = variants {N ; M}} ;
-
-recordExpand :: Type -> Term -> Err Term
-recordExpand typ trm = case typ of
-  RecType tys -> case trm of
-    FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
-    _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
-  _ -> return trm
-
--}
--- | auxiliaries for compiling the resource
-
-mkLinDefault :: SourceGrammar -> Type -> Err Term
-mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
- where
-   mkDefField typ = case typ 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           -> do vs <- lookupParamValues gr p
-                          case vs of
-                            v:_ -> return v
-                            _   -> Bad (render ("no parameter values given to type" <+> ppQIdent Qualified p))
-     RecType r  -> do
-       let (ls,ts) = unzip r
-       ts <- mapM mkDefField ts
-       return $ R (zipWith assign ls ts)
-     _ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
-     _ -> Bad (render ("linearization type field cannot be" <+> typ))
-
-mkLinReference :: SourceGrammar -> Type -> Err Term
-mkLinReference gr typ =
- liftM (Abs Explicit varStr) $
-   case mkDefField typ (Vr varStr) of
-     Bad "no string" -> return Empty
-     x               -> x
- where
-   mkDefField ty trm =
-     case ty of
-       Table pty ty -> do ps <- allParamValues gr pty
-                          case ps of
-                            []     -> Bad "no string"
-                            (p:ps) -> mkDefField ty (S trm p)
-       Sort s | s == cStr -> return trm
-       QC p       -> Bad "no string"
-       RecType [] -> Bad "no string"
-       RecType rs -> do
-         msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
-           `mplus` Bad "no string"
-       _ | Just _ <- isTypeInts typ -> Bad "no string"
-       _ -> Bad (render ("linearization type field cannot be" <+> typ))
-
-evalPrintname :: GlobalEnv -> Ident -> L Term -> L Term
-evalPrintname resenv c (L loc pr) = L loc (normalForm resenv (L loc c) pr)
-
--- do even more: factor parametric branches
-
-factor :: Bool -> Ident -> Int -> Term -> Term
-factor param c i t =
-  case t of
-    T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
-    _               -> composSafeOp (factor param c i) t
-  where
-    factors ty pvs0
-                 | not param = V ty (map snd pvs0)
-    factors ty []            = V ty []
-    factors ty pvs0@[(p,v)]  = V ty [v]
-    factors ty pvs0@(pv:pvs) =
-      let t  = mkFun pv
-          ts = map mkFun pvs
-      in if all (==t) ts
-           then T (TTyped ty) (mkCases t)
-           else V ty (map snd pvs0)
-
-    --- we hope this will be fresh and don't check... in GFC would be safe
-    qvar = identS ("q_" ++ showIdent c ++ "__" ++ show i)
-
-    mkFun (patt, val) = replace (patt2term patt) (Vr qvar) val
-    mkCases t = [(PV qvar, t)]
-
---  we need to replace subterms
-replace :: Term -> Term -> Term -> Term
-replace old new trm =
-  case trm of
-    -- these are the important cases, since they can correspond to patterns
-    QC _     | trm == old -> new
-    App _ _  | trm == old -> new
-    R _      | trm == old -> new
-    App x y               -> App (replace old new x) (replace old new y)
-    _                     -> composSafeOp (replace old new) trm

src/compiler/GF/Compile/PGFtoJS.hs

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

src/compiler/GF/Compile/PGFtoJSON.hs

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

src/compiler/GF/Compile/PGFtoProlog.hs

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

src/compiler/GF/Compile/PGFtoPython.hs

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

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

@@ -1,800 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-
-import GF.Infra.CheckM
-import GF.Data.Operations
-
-import GF.Grammar
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Grammar.PatternMatch
-import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
-import GF.Compile.TypeCheck.Primitives
-
-import Data.List
-import Control.Monad
-import GF.Text.Pretty
-
-computeLType :: SourceGrammar -> Context -> Type -> Check Type
-computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
- where
-  comp g ty = case ty of
-    _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
-      | isPredefConstant ty     -> return ty ---- shouldn't be needed
-
-    Q (m,ident) -> checkIn ("module" <+> m) $ do
-      ty' <- lookupResDef gr (m,ident)
-      if ty' == ty then return ty else comp g ty' --- is this necessary to test?
-
-    AdHocOverload ts -> do
-     over <- getOverload gr g (Just typeType) t
-     case over of
-       Just (tr,_) -> return tr
-       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
-
-    Vr ident  -> checkLookup ident g -- never needed to compute!
-
-    App f a -> do
-      f' <- comp g f
-      a' <- comp g a
-      case f' of
-        Abs b x t -> comp ((b,x,a'):g) t
-        _ -> return $ App f' a'
-
-    Prod bt x a b -> do
-      a' <- comp g a
-      b' <- comp ((bt,x,Vr x) : g) b
-      return $ Prod bt x a' b'
-
-    Abs bt x b -> do
-      b' <- comp ((bt,x,Vr x):g) b
-      return $ Abs bt x b'
-
-    Let (x,(_,a)) b -> comp ((Explicit,x,a):g) b
-
-    ExtR r s -> do
-      r' <- comp g r
-      s' <- comp g s
-      case (r',s') of
-        (RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
-        _ -> return $ ExtR r' s'
-
-    RecType fs -> do
-      let fs' = sortRec fs
-      liftM RecType $ mapPairsM (comp g) fs'
-
-    ELincat c t -> do
-      t' <- comp g t
-      lockRecType c t' ---- locking to be removed AR 20/6/2009
-
-    _ | ty == typeTok -> return typeStr
-
-    _ -> composOp (comp g) ty
-
--- the underlying algorithms
-
-inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
-inferLType gr g trm = case trm of
-
-   Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
-                                                Just ty -> return ty
-                                                Nothing -> checkError ("unknown in Predef:" <+> ident)
-
-   Q ident -> checks [
-     termWith trm $ lookupResType gr ident >>= computeLType gr g
-     ,
-     lookupResDef gr ident >>= inferLType gr g
-     ,
-     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
-     ]
-
-   QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
-                                                 Just ty -> return ty
-                                                 Nothing -> checkError ("unknown in Predef:" <+> ident)
-
-   QC ident -> checks [
-       termWith trm $ lookupResType gr ident >>= computeLType gr g
-       ,
-       lookupResDef gr ident >>= inferLType gr g
-       ,
-       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
-       ]
-
-   Vr ident -> termWith trm $ checkLookup ident g
-
-   Typed e t -> do
-     t' <- computeLType gr g t
-     checkLType gr g e t'
-
-   AdHocOverload ts -> do
-     over <- getOverload gr g Nothing trm
-     case over of
-       Just trty -> return trty
-       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
-
-   App f a -> do
-     over <- getOverload gr g Nothing trm
-     case over of
-       Just trty -> return trty
-       _ -> do
-         (f',fty) <- inferLType gr g f
-         fty' <- computeLType gr g fty
-         case fty' of
-           Prod bt z arg val -> do
-             a' <- justCheck g a arg
-             ty <- if isWildIdent z
-                      then return val
-                      else substituteLType [(bt,z,a')] val
-             return (App f' a',ty)
-           _ ->
-             let term = ppTerm Unqualified 0 f
-                 funName = pp . head . words .render $ term
-              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
-                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")
-
-   S f x -> do
-     (f', fty) <- inferLType gr g f
-     case fty of
-       Table arg val -> do
-         x'<- justCheck g x arg
-         return (S f' x', val)
-       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
-
-   P t i -> do
-     (t',ty) <- inferLType gr g t   --- ??
-     ty' <- computeLType gr g ty
-     let tr2 = P t' i
-     termWith tr2 $ case ty' of
-       RecType ts -> case lookup i ts of
-                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
-                       Just x  -> return x
-       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
-                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
-
-   R r -> do
-     let (ls,fs) = unzip r
-     fsts <- mapM inferM fs
-     let ts = [ty | (Just ty,_) <- fsts]
-     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
-     return $ (R (zip ls fsts), RecType (zip ls ts))
-
-   T (TTyped arg) pts -> do
-     (_,val) <- checks $ map (inferCase (Just arg)) pts
-     checkLType gr g trm (Table arg val)
-   T (TComp arg) pts -> do
-     (_,val) <- checks $ map (inferCase (Just arg)) pts
-     checkLType gr g trm (Table arg val)
-   T ti pts -> do  -- tries to guess: good in oper type inference
-     let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
-     case pts' of
-       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
-----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
-       _  -> do
-         (arg,val) <- checks $ map (inferCase Nothing) pts'
-         checkLType gr g trm (Table arg val)
-   V arg pts -> do
-     (_,val) <- checks $ map (inferLType gr g) pts
---   return (trm, Table arg val) -- old, caused issue 68
-     checkLType gr g trm (Table arg val)
-
-   K s  -> do
-     if elem ' ' s
-        then do
-          let ss = foldr C Empty (map K (words s))
-          ----- removed irritating warning AR 24/5/2008
-          ----- checkWarn ("token \"" ++ s ++
-          -----              "\" converted to token list" ++ prt ss)
-          return (ss, typeStr)
-        else return (trm, typeStr)
-
-   EInt i -> return (trm, typeInt)
-
-   EFloat i -> return (trm, typeFloat)
-
-   Empty -> return (trm, typeStr)
-
-   C s1 s2 ->
-     check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
-
-   Glue s1 s2 ->
-     check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
-
----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
-   Strs (Cn c : ts) | c == cConflict -> do
-     checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
-     inferLType gr g (head ts)
-
-   Strs ts -> do
-     ts' <- mapM (\t -> justCheck g t typeStr) ts
-     return (Strs ts', typeStrs)
-
-   Alts t aa -> do
-     t'  <- justCheck g t typeStr
-     aa' <- flip mapM aa (\ (c,v) -> do
-        c' <- justCheck g c typeStr
-        v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
-        return (c',v'))
-     return (Alts t' aa', typeStr)
-
-   RecType r -> do
-     let (ls,ts) = unzip r
-     ts' <- mapM (flip (justCheck g) typeType) ts
-     return (RecType (zip ls ts'), typeType)
-
-   ExtR r s -> do
-
----     over <- getOverload gr g Nothing r
----     let r1 = maybe r fst over
-     let r1 = r ---
-
-     (r',rT) <- inferLType gr g r1
-     rT'     <- computeLType gr g rT
-
-     (s',sT) <- inferLType gr g s
-     sT'     <- computeLType gr g sT
-
-     let trm' = ExtR r' s'
-     case (rT', sT') of
-       (RecType rs, RecType ss) -> do
-         let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
-         checkLType gr g trm' rt ---- return (trm', rt)
-       _ | rT' == typeType && sT' == typeType -> do
-         return (trm', typeType)
-       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
-
-   Sort _     ->
-     termWith trm $ return typeType
-
-   Prod bt x a b -> do
-     a' <- justCheck g a typeType
-     b' <- justCheck ((bt,x,a'):g) b typeType
-     return (Prod bt x a' b', typeType)
-
-   Table p t  -> do
-     p' <- justCheck g p typeType --- check p partype!
-     t' <- justCheck g t typeType
-     return $ (Table p' t', typeType)
-
-   FV vs -> do
-     (_,ty) <- checks $ map (inferLType gr g) vs
----     checkIfComplexVariantType trm ty
-     checkLType gr g trm ty
-
-   EPattType ty -> do
-     ty' <- justCheck g ty typeType
-     return (EPattType ty',typeType)
-   EPatt p -> do
-     ty <- inferPatt p
-     return (trm, EPattType ty)
-
-   ELin c trm -> do
-     (trm',ty) <- inferLType gr g trm
-     ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
-     return $ (ELin c trm', ty')
-
-   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
-
- where
-   isPredef m = elem m [cPredef,cPredefAbs]
-
-   justCheck g ty te = checkLType gr g ty te >>= return . fst
-
-   -- for record fields, which may be typed
-   inferM (mty, t) = do
-     (t', ty') <- case mty of
-       Just ty -> checkLType gr g t ty
-       _ -> inferLType gr g t
-     return (Just ty',t')
-
-   inferCase mty (patt,term) = do
-     arg  <- maybe (inferPatt patt) return mty
-     cont <- pattContext gr g arg patt
-     (_,val) <- inferLType gr (reverse cont ++ g) term
-     return (arg,val)
-   isConstPatt p = case p of
-     PC _ ps -> True --- all isConstPatt ps
-     PP _ ps -> True --- all isConstPatt ps
-     PR ps -> all (isConstPatt . snd) ps
-     PT _ p -> isConstPatt p
-     PString _ -> True
-     PInt _ -> True
-     PFloat _ -> True
-     PChar -> True
-     PChars _ -> True
-     PSeq p q -> isConstPatt p && isConstPatt q
-     PAlt p q -> isConstPatt p && isConstPatt q
-     PRep p -> isConstPatt p
-     PNeg p -> isConstPatt p
-     PAs _ p -> isConstPatt p
-     _ -> False
-
-   inferPatt p = case p of
-     PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
-     PAs _ p  -> inferPatt p
-     PNeg p   -> inferPatt p
-     PAlt p q -> checks [inferPatt p, inferPatt q]
-     PSeq _ _ -> return $ typeStr
-     PRep _   -> return $ typeStr
-     PChar    -> return $ typeStr
-     PChars _ -> return $ typeStr
-     _ -> inferLType gr g (patt2term p) >>= return . snd
-
--- type inference: Nothing, type checking: Just t
--- the latter permits matching with value type
-getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
-getOverload gr g mt ot = case appForm ot of
-     (f@(Q c), ts) -> case lookupOverload gr c of
-       Ok typs -> do
-         ttys <- mapM (inferLType gr g) ts
-         v <- matchOverload f typs ttys
-         return $ Just v
-       _ -> return Nothing
-     (AdHocOverload cs@(f:_), ts) -> do     --- the function name f is only used in error messages
-       let typs = concatMap collectOverloads cs
-       ttys <- mapM (inferLType gr g) ts
-       v <- matchOverload f typs ttys
-       return $ Just v
-     _ -> return Nothing
-
- where
-   collectOverloads tr@(Q c) = case lookupOverload gr c of
-     Ok typs -> typs
-     _ -> case lookupResType gr c of
-       Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
-       _ -> []
-   collectOverloads _ = [] --- constructors QC
-
-   matchOverload f typs ttys = do
-     let (tts,tys) = unzip ttys
-     let vfs = lookupOverloadInstance tys typs
-     let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
-     let showTypes ty = hsep (map ppType ty)
-
-
-     let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
-
-     -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
-     let (stysError,stypsError) = if elem (render stys) (map render styps)
-            then (hsep (map (ppTerm Unqualified 0) tys), [hsep (map (ppTerm Unqualified 0) ty) | (ty,_) <- typs])
-            else (stys,styps)
-
-     case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
-       ([(_,val,fun)],_) -> return (mkApp fun tts, val)
-       ([],[(pre,val,fun)]) -> do
-         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
-                      "for" $$
-                      nest 2 (showTypes tys) $$
-                      "using" $$
-                      nest 2 (showTypes pre)
-         return (mkApp fun tts, val)
-       ([],[]) -> do
-         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
-                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
-                      "for argument list" $$
-                      nest 2 stysError $$
-                      "among alternatives" $$
-                      nest 2 (vcat stypsError)
-
-
-       (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
-         ([(val,fun)],_) -> do
-           return (mkApp fun tts, val)
-         ([],[(val,fun)]) -> do
-           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
-           return (mkApp fun tts, val)
-
------ unsafely exclude irritating warning AR 24/5/2008
------           checkWarn $ "overloading of" +++ prt f +++
------             "resolved by excluding partial applications:" ++++
------             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
-
---- now forgiving ambiguity with a warning AR 1/2/2014
---  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
---  But it also gives a chance to ambiguous overloadings that were banned before.
-         (nps1,nps2) -> do
-              checkWarn $  "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
-                  ----     "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
-                           "resolved by selecting the first of the alternatives" $$
-                           nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
-              case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
-                 [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
-                 h:_ -> return h
-
-   matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
-
-   unlocked v = case v of
-     RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
-     _ -> v
-   ---- TODO: accept subtypes
-   ---- TODO: use a trie
-   lookupOverloadInstance tys typs =
-     [((pre,mkFunType rest val, t),isExact) |
-       let lt = length tys,
-       (ty,(val,t)) <- typs, length ty >= lt,
-       let (pre,rest) = splitAt lt ty,
-       let isExact = pre == tys,
-       isExact || map unlocked pre == map unlocked tys
-     ]
-
-   noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v]
-
-   noProd ty = case ty of
-     Prod _ _ _ _ -> False
-     _ -> True
-
-checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
-checkLType gr g trm typ0 = do
-  typ <- computeLType gr g typ0
-
-  case trm of
-
-    Abs bt x c -> do
-      case typ of
-        Prod bt' z a b -> do
-          (c',b') <- if isWildIdent z
-                       then checkLType gr ((bt,x,a):g) c b
-                       else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
-                               checkLType gr ((bt,x,a):g) c b'
-          return $ (Abs bt x c', Prod bt' z a b')
-        _ -> checkError $ "function type expected instead of" <+> ppType typ $$
-                          "\n   ** Double-check that the type signature of the operation" $$
-                          "matches the number of arguments given to it.\n"
-
-    App f a -> do
-       over <- getOverload gr g (Just typ) trm
-       case over of
-         Just trty -> return trty
-         _ -> do
-          (trm',ty') <- inferLType gr g trm
-          termWith trm' $ checkEqLType gr g typ ty' trm'
-
-    AdHocOverload ts -> do
-      over <- getOverload gr g Nothing trm
-      case over of
-        Just trty -> return trty
-        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
-
-    Q _ -> do
-       over <- getOverload gr g (Just typ) trm
-       case over of
-         Just trty -> return trty
-         _ -> do
-          (trm',ty') <- inferLType gr g trm
-          termWith trm' $ checkEqLType gr g typ ty' trm'
-
-    T _ [] ->
-      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
-    T _ cs -> case typ of
-      Table arg val -> do
-        case allParamValues gr arg of
-          Ok vs -> do
-            let ps0 = map fst cs
-            ps <- testOvershadow ps0 vs
-            if null ps
-              then return ()
-              else checkWarn ("patterns never reached:" $$
-                              nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
-          _ -> return () -- happens with variable types
-        cs' <- mapM (checkCase arg val) cs
-        return (T (TTyped arg) cs', typ)
-      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
-    V arg0 vs ->
-      case typ of
-        Table arg1 val ->
-           do arg' <- checkEqLType gr g arg0 arg1 trm
-              vs1 <- allParamValues gr arg1
-              if length vs1 == length vs
-                 then return ()
-                 else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
-              vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
-              return (V arg' vs',typ)
-
-    R r -> case typ of --- why needed? because inference may be too difficult
-       RecType rr -> do
-       --let (ls,_) = unzip rr        -- labels of expected type
-         fsts <- mapM (checkM r) rr   -- check that they are found in the record
-         return $ (R fsts, typ)       -- normalize record
-
-       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
-
-    ExtR r s -> case typ of
-       _ | typ == typeType -> do
-         trm' <- computeLType gr g trm
-         case trm' of
-           RecType _ -> termWith trm' $ return typeType
-           ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
-                                      -- ext t = t ** ...
-           _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
-
-       RecType rr -> do
-
-         ll2 <- case s of
-           R ss -> return $ map fst ss
-           _ -> do
-             (s',typ2) <- inferLType gr g s
-             case typ2 of
-               RecType ss -> return $ map fst ss
-               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
-         let ll1 = [l | (l,_) <- rr, notElem l ll2]
-
----         over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020
----         let r1 = maybe r fst over
-         let r1 = r ---
-
-         (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1])
-         (s',_) <- checkLType gr g s  (RecType [field | field@(l,_) <- rr, elem l ll2])
-
-         let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2])
-         return (rec, typ)
-
-       ExtR ty ex -> do
-         r' <- justCheck g r ty
-         s' <- justCheck g s ex
-         return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
-
-       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
-
-    FV vs -> do
-      ttys <- mapM (flip (checkLType gr g) typ) vs
----      checkIfComplexVariantType trm typ
-      return (FV (map fst ttys), typ) --- typ' ?
-
-    S tab arg -> checks [ do
-      (tab',ty) <- inferLType gr g tab
-      ty'       <- computeLType gr g ty
-      case ty' of
-        Table p t -> do
-          (arg',val) <- checkLType gr g arg p
-          checkEqLType gr g typ t trm
-          return (S tab' arg', t)
-        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
-     , do
-      (arg',ty) <- inferLType gr g arg
-      ty'       <- computeLType gr g ty
-      (tab',_)  <- checkLType gr g tab (Table ty' typ)
-      return (S tab' arg', typ)
-      ]
-    Let (x,(mty,def)) body -> case mty of
-      Just ty -> do
-        (ty0,_)    <- checkLType gr g ty typeType
-        (def',ty') <- checkLType gr g def ty0
-        body' <- justCheck ((Explicit,x,ty'):g) body typ
-        return (Let (x,(Just ty',def')) body', typ)
-      _ -> do
-        (def',ty) <- inferLType gr g def  -- tries to infer type of local constant
-        checkLType gr g (Let (x,(Just ty,def')) body) typ
-
-    ELin c tr -> do
-      tr1 <- unlockRecord c tr
-      checkLType gr g tr1 typ
-
-    _ -> do
-      (trm',ty') <- inferLType gr g trm
-      termWith trm' $ checkEqLType gr g typ ty' trm'
- where
-   justCheck g ty te = checkLType gr g ty te >>= return . fst
-{-
-   recParts rr t = (RecType rr1,RecType rr2) where
-     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr
--}
-   checkM rms (l,ty) = case lookup l rms of
-     Just (Just ty0,t) -> do
-       checkEqLType gr g ty ty0 t
-       (t',ty') <- checkLType gr g t ty
-       return (l,(Just ty',t'))
-     Just (_,t) -> do
-       (t',ty') <- checkLType gr g t ty
-       return (l,(Just ty',t'))
-     _ -> checkError $
-            if isLockLabel l
-              then let cat = drop 5 (showIdent (label2ident l))
-                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
-                      "; try wrapping it with lin" <+> cat
-              else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
-
-   checkCase arg val (p,t) = do
-     cont <- pattContext gr g arg p
-     t' <- justCheck (reverse cont ++ g) t val
-     return (p,t')
-
-pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
-pattContext env g typ p = case p of
-  PV x -> return [(Explicit,x,typ)]
-  PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
-    t <- lookupResType env (q,c)
-    let (cont,v) = typeFormCnc t
-    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
-              (length cont == length ps)
-    checkEqLType env g typ v (patt2term p)
-    mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
-  PR r -> do
-    typ' <- computeLType env g typ
-    case typ' of
-      RecType t -> do
-        let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
-        ----- checkWarn $ prt p ++++ show pts ----- debug
-        mapM (uncurry (pattContext env g)) pts >>= return . concat
-      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
-  PT t p' -> do
-    checkEqLType env g typ t (patt2term p')
-    pattContext env g typ p'
-
-  PAs x p -> do
-    g' <- pattContext env g typ p
-    return ((Explicit,x,typ):g')
-
-  PAlt p' q -> do
-    g1 <- pattContext env g typ p'
-    g2 <- pattContext env g typ q
-    let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
-    checkCond
-      ("incompatible bindings of" <+>
-       fsep pts <+>
-       "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
-    return g1 -- must be g1 == g2
-  PSeq p q -> do
-    g1 <- pattContext env g typ p
-    g2 <- pattContext env g typ q
-    return $ g1 ++ g2
-  PRep p' -> noBind typeStr p'
-  PNeg p' -> noBind typ p'
-
-  _ -> return [] ---- check types!
- where
-   noBind typ p' = do
-    co <- pattContext env g typ p'
-    if not (null co)
-      then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
-           >> return []
-      else return []
-
-checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
-checkEqLType gr g t u trm = do
-  (b,t',u',s) <- checkIfEqLType gr g t u trm
-  case b of
-    True  -> return t'
-    False ->
-      let inferredType = ppTerm Qualified 0 u
-          expectedType = ppTerm Qualified 0 t
-          term = ppTerm Unqualified 0 trm
-          funName = pp . head . words .render $ term
-          helpfulMsg =
-            case (arrows inferredType, arrows expectedType) of
-              (0,0) -> pp "" -- None of the types is a function
-              _ -> "\n   **" <+>
-                  if expectedType `isLessApplied` inferredType
-                    then "Maybe you gave too few arguments to" <+> funName
-                    else pp "Double-check that type signature and number of arguments match."
-      in checkError $ s <+> "type of" <+> term $$
-                            "expected:" <+> expectedType $$ -- ppqType t u $$
-                            "inferred:" <+> inferredType $$ -- ppqType u t
-                            helpfulMsg
-  where
-    -- count the number of arrows in the prettyprinted term
-    arrows :: Doc -> Int
-    arrows = length . filter (=="->") . words . render
-
-    -- If prettyprinted type t has fewer arrows then prettyprinted type u,
-    -- then t is "less applied", and we can print out more helpful error msg.
-    isLessApplied :: Doc -> Doc -> Bool
-    isLessApplied t u = arrows t < arrows u
-
-checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
-checkIfEqLType gr g t u trm = do
-  t' <- computeLType gr g t
-  u' <- computeLType gr g u
-  case t' == u' || alpha [] t' u' of
-    True -> return (True,t',u',[])
-    -- forgive missing lock fields by only generating a warning.
-    --- better: use a flag to forgive? (AR 31/1/2006)
-    _ -> case missingLock [] t' u' of
-      Ok lo -> do
-        checkWarn $ "missing lock field" <+> fsep lo
-        return (True,t',u',[])
-      Bad s -> return (False,t',u',s)
-
-  where
-
-   -- check that u is a subtype of t
-   --- quick hack version of TC.eqVal
-   alpha g t u = case (t,u) of
-
-     -- error (the empty type!) is subtype of any other type
-     (_,u) | u == typeError -> True
-
-     -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
-
-     -- record subtyping
-     (RecType rs, RecType ts) -> all (\ (l,a) ->
-                                   any (\ (k,b) -> l == k && alpha g a b) ts) rs
-     (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
-     (ExtR r s, t) -> alpha g r t || alpha g s t
-
-     -- the following say that Ints n is a subset of Int and of Ints m >= n
-     -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
-     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
-           | Just _ <- isTypeInts t, u == typeInt           -> True ---- check size!
-           | t == typeInt,           Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
-
-     ---- this should be made in Rename
-     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
-                                   || m == n --- for Predef
-     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
-     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
-     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
-                                   || elem n (allExtendsPlus gr m)
-
-     -- contravariance
-     (Table a b,  Table c d)  -> alpha g c a && alpha g b d
-     (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
-     _                        -> t == u
-     --- the following should be one-way coercions only. AR 4/1/2001
-                                  || elem t sTypes && elem u sTypes
-                                  || (t == typeType && u == typePType)
-                                  || (u == typeType && t == typePType)
-
-   missingLock g t u = case (t,u) of
-     (RecType rs, RecType ts) ->
-       let
-         ls = [l | (l,a) <- rs,
-                   not (any (\ (k,b) -> alpha g a b && l == k) ts)]
-         (locks,others) = partition isLockLabel ls
-       in case others of
-         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
-         _ -> return locks
-     -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> do
-        ls1 <- missingLock g c a
-        ls2 <- missingLock g b d
-        return $ ls1 ++ ls2
-
-     _ -> Bad ""
-
-   sTypes = [typeStr, typeTok, typeString]
-
--- auxiliaries
-
--- | light-weight substitution for dep. types
-substituteLType :: Context -> Type -> Check Type
-substituteLType g t = case t of
-  Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g]
-  _ -> composOp (substituteLType g) t
-
-termWith :: Term -> Check Type -> Check (Term, Type)
-termWith t ct = do
-  ty <- ct
-  return (t,ty)
-
--- | compositional check\/infer of binary operations
-check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
-          Term -> Term -> Type -> Check (Term,Type)
-check2 chk con a b t = do
-  a' <- chk a
-  b' <- chk b
-  return (con a' b', t)
-
--- printing a type with a lock field lock_C as C
-ppType :: Type -> Doc
-ppType ty =
-  case ty of
-    RecType fs   -> case filter isLockLabel $ map fst fs of
-                      [lock] -> pp (drop 5 (showIdent (label2ident lock)))
-                      _      -> ppTerm Unqualified 0 ty
-    Prod _ x a b -> ppType a <+> "->" <+> ppType b
-    _            -> ppTerm Unqualified 0 ty
-{-
-ppqType :: Type -> Type -> Doc
-ppqType t u = case (ppType t, ppType u) of
-  (pt,pu) | render pt == render pu -> ppTerm Qualified 0 t
-  (pt,_) -> pt
--}
-checkLookup :: Ident -> Context -> Check Type
-checkLookup x g =
-  case [ty | (b,y,ty) <- g, x == y] of
-    []     -> checkError ("unknown variable" <+> x)
-    (ty:_) -> return ty

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

@@ -1,802 +0,0 @@
-{-# LANGUAGE CPP #-}
-module GF.Compile.TypeCheck.ConcreteNew( checkLType, inferLType ) where
-
--- The code here is based on the paper:
--- Simon Peyton Jones, Dimitrios Vytiniotis, Stephanie Weirich.
--- Practical type inference for arbitrary-rank types.
--- 14 September 2011
-
-import GF.Grammar hiding (Env, VGen, VApp, VRecType)
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Grammar.Lockfield
-import GF.Compile.Compute.Concrete
-import GF.Compile.Compute.Predef(predef,predefName)
-import GF.Infra.CheckM
-import GF.Data.Operations
-import Control.Applicative(Applicative(..))
-import Control.Monad(ap,liftM,mplus)
-import GF.Text.Pretty
-import Data.List (nub, (\\), tails)
-import qualified Data.IntMap as IntMap
-import Data.Maybe(fromMaybe,isNothing)
-import qualified Control.Monad.Fail as Fail
-
-checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type)
-checkLType ge t ty = runTcM $ do
-  vty <- liftErr (eval ge [] ty)
-  (t,_) <- tcRho ge [] t (Just vty)
-  t <- zonkTerm t
-  return (t,ty)
-
-inferLType :: GlobalEnv -> Term -> Check (Term, Type)
-inferLType ge t = runTcM $ do
-  (t,ty) <- inferSigma ge [] t
-  t  <- zonkTerm t
-  ty <- zonkTerm =<< tc_value2term (geLoc ge) [] ty
-  return (t,ty)
-
-inferSigma :: GlobalEnv -> Scope -> Term -> TcM (Term,Sigma)
-inferSigma ge scope t = do                                      -- GEN1
-  (t,ty) <- tcRho ge scope t Nothing
-  env_tvs <- getMetaVars (geLoc ge) (scopeTypes scope)
-  res_tvs <- getMetaVars (geLoc ge) [(scope,ty)]
-  let forall_tvs = res_tvs \\ env_tvs
-  quantify ge scope t forall_tvs ty
-
-Just vtypeInt   = fmap (flip VApp []) (predef cInt)
-Just vtypeFloat = fmap (flip VApp []) (predef cFloat)
-Just vtypeInts  = fmap (\p i -> VApp p [VInt i]) (predef cInts)
-vtypeStr   = VSort cStr
-vtypeStrs  = VSort cStrs
-vtypeType  = VSort cType
-vtypePType = VSort cPType
-
-tcRho :: GlobalEnv -> Scope -> Term -> Maybe Rho -> TcM (Term, Rho)
-tcRho ge scope t@(EInt i)   mb_ty = instSigma ge scope t (vtypeInts i) mb_ty -- INT
-tcRho ge scope t@(EFloat _) mb_ty = instSigma ge scope t vtypeFloat mb_ty    -- FLOAT
-tcRho ge scope t@(K _)      mb_ty = instSigma ge scope t vtypeStr   mb_ty    -- STR
-tcRho ge scope t@(Empty)    mb_ty = instSigma ge scope t vtypeStr   mb_ty
-tcRho ge scope t@(Vr v)     mb_ty = do                          -- VAR
-  case lookup v scope of
-    Just v_sigma -> instSigma ge scope t v_sigma mb_ty
-    Nothing      -> tcError ("Unknown variable" <+> v)
-tcRho ge scope t@(Q id)     mb_ty =
-  runTcA (tcOverloadFailed t) $
-    tcApp ge scope t `bindTcA` \(t,ty) ->
-      instSigma ge scope t ty mb_ty
-tcRho ge scope t@(QC id)    mb_ty =
-  runTcA (tcOverloadFailed t) $
-    tcApp ge scope t `bindTcA` \(t,ty) ->
-      instSigma ge scope t ty mb_ty
-tcRho ge scope t@(App fun arg) mb_ty = do
-  runTcA (tcOverloadFailed t) $
-    tcApp ge scope t `bindTcA` \(t,ty) ->
-      instSigma ge scope t ty mb_ty
-tcRho ge scope (Abs bt var body) Nothing = do                   -- ABS1
-  i <- newMeta scope vtypeType
-  let arg_ty = VMeta i (scopeEnv scope) []
-  (body,body_ty) <- tcRho ge ((var,arg_ty):scope) body Nothing
-  return (Abs bt var body, (VProd bt arg_ty identW (Bind (const body_ty))))
-tcRho ge scope t@(Abs Implicit var body) (Just ty) = do         -- ABS2
-  (bt, var_ty, body_ty) <- unifyFun ge scope ty
-  if bt == Implicit
-    then return ()
-    else tcError (ppTerm Unqualified 0 t <+> "is an implicit function, but no implicit function is expected")
-  (body, body_ty) <- tcRho ge ((var,var_ty):scope) body (Just (body_ty (VGen (length scope) [])))
-  return (Abs Implicit var body,ty)
-tcRho ge scope (Abs Explicit var body) (Just ty) = do           -- ABS3
-  (scope,f,ty') <- skolemise ge scope ty
-  (_,var_ty,body_ty) <- unifyFun ge scope ty'
-  (body, body_ty) <- tcRho ge ((var,var_ty):scope) body (Just (body_ty (VGen (length scope) [])))
-  return (f (Abs Explicit var body),ty)
-tcRho ge scope (Let (var, (mb_ann_ty, rhs)) body) mb_ty = do    -- LET
-  (rhs,var_ty) <- case mb_ann_ty of
-                    Nothing     -> inferSigma ge scope rhs
-                    Just ann_ty -> do (ann_ty, _) <- tcRho ge scope ann_ty (Just vtypeType)
-                                      v_ann_ty <- liftErr (eval ge (scopeEnv scope) ann_ty)
-                                      (rhs,_) <- tcRho ge scope rhs (Just v_ann_ty)
-                                      return (rhs, v_ann_ty)
-  (body, body_ty) <- tcRho ge ((var,var_ty):scope) body mb_ty
-  var_ty <- tc_value2term (geLoc ge) (scopeVars scope) var_ty
-  return (Let (var, (Just var_ty, rhs)) body, body_ty)
-tcRho ge scope (Typed body ann_ty) mb_ty = do                   -- ANNOT
-  (ann_ty, _) <- tcRho ge scope ann_ty (Just vtypeType)
-  v_ann_ty <- liftErr (eval ge (scopeEnv scope) ann_ty)
-  (body,_) <- tcRho ge scope body (Just v_ann_ty)
-  instSigma ge scope (Typed body ann_ty) v_ann_ty mb_ty
-tcRho ge scope (FV ts) mb_ty = do
-  case ts of
-    []     -> do i <- newMeta scope vtypeType
-                 instSigma ge scope (FV []) (VMeta i (scopeEnv scope) []) mb_ty
-    (t:ts) -> do (t,ty) <- tcRho ge scope t mb_ty
-
-                 let go []     ty = return ([],ty)
-                     go (t:ts) ty = do (t, ty) <- tcRho ge scope t (Just ty)
-                                       (ts,ty) <- go ts ty
-                                       return (t:ts,ty)
-
-                 (ts,ty) <- go ts ty
-                 return (FV (t:ts), ty)
-tcRho ge scope t@(Sort s) mb_ty = do
-  instSigma ge scope t vtypeType mb_ty
-tcRho ge scope t@(RecType rs) Nothing   = do
-  (rs,mb_ty) <- tcRecTypeFields ge scope rs Nothing
-  return (RecType rs,fromMaybe vtypePType mb_ty)
-tcRho ge scope t@(RecType rs) (Just ty) = do
-  (scope,f,ty') <- skolemise ge scope ty
-  case ty' of
-    VSort s
-      | s == cType  -> return ()
-      | s == cPType -> return ()
-    VMeta i env vs  -> case rs of
-                         [] -> unifyVar ge scope i env vs vtypePType
-                         _  -> return ()
-    ty              -> do ty <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) ty
-                          tcError ("The record type" <+> ppTerm Unqualified 0 t $$
-                                   "cannot be of type" <+> ppTerm Unqualified 0 ty)
-  (rs,mb_ty) <- tcRecTypeFields ge scope rs (Just ty')
-  return (f (RecType rs),ty)
-tcRho ge scope t@(Table p res) mb_ty = do
-  (p,  p_ty)   <- tcRho ge scope p   (Just vtypePType)
-  (res,res_ty) <- tcRho ge scope res (Just vtypeType)
-  instSigma ge scope (Table p res) vtypeType mb_ty
-tcRho ge scope (Prod bt x ty1 ty2) mb_ty = do
-  (ty1,ty1_ty) <- tcRho ge scope ty1 (Just vtypeType)
-  vty1 <- liftErr (eval ge (scopeEnv scope) ty1)
-  (ty2,ty2_ty) <- tcRho ge ((x,vty1):scope) ty2 (Just vtypeType)
-  instSigma ge scope (Prod bt x ty1 ty2) vtypeType mb_ty
-tcRho ge scope (S t p) mb_ty = do
-  p_ty   <- fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta scope vtypePType
-  res_ty <- case mb_ty of
-              Nothing -> fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta scope vtypeType
-              Just ty -> return ty
-  let t_ty = VTblType p_ty res_ty
-  (t,t_ty) <- tcRho ge scope t (Just t_ty)
-  (p,_) <- tcRho ge scope p (Just p_ty)
-  return (S t p, res_ty)
-tcRho ge scope (T tt ps) Nothing = do                           -- ABS1/AABS1 for tables
-  p_ty   <- case tt of
-              TRaw      -> fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta scope vtypePType
-              TTyped ty -> do (ty, _) <- tcRho ge scope ty (Just vtypeType)
-                              liftErr (eval ge (scopeEnv scope) ty)
-  (ps,mb_res_ty) <- tcCases ge scope ps p_ty Nothing
-  res_ty <- case mb_res_ty of
-              Just res_ty -> return res_ty
-              Nothing     -> fmap (\i -> VMeta i (scopeEnv scope) []) $ newMeta scope vtypeType
-  p_ty_t <- tc_value2term (geLoc ge) [] p_ty
-  return (T (TTyped p_ty_t) ps, VTblType p_ty res_ty)
-tcRho ge scope (T tt ps) (Just ty) = do                         -- ABS2/AABS2 for tables
-  (scope,f,ty') <- skolemise ge scope ty
-  (p_ty, res_ty) <- unifyTbl ge scope ty'
-  case tt of
-    TRaw      -> return ()
-    TTyped ty -> do (ty, _) <- tcRho ge scope ty (Just vtypeType)
-                    return ()--subsCheckRho ge scope -> Term ty res_ty
-  (ps,Just res_ty) <- tcCases ge scope ps p_ty (Just res_ty)
-  p_ty_t <- tc_value2term (geLoc ge) [] p_ty
-  return (f (T (TTyped p_ty_t) ps), VTblType p_ty res_ty)
-tcRho ge scope (R rs) Nothing = do
-  lttys <- inferRecFields ge scope rs
-  rs <- mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
-  return (R        rs,
-          VRecType [(l, ty) | (l,t,ty) <- lttys]
-         )
-tcRho ge scope (R rs) (Just ty) = do
-  (scope,f,ty') <- skolemise ge scope ty
-  case ty' of
-    (VRecType ltys) -> do lttys <- checkRecFields ge scope rs ltys
-                          rs <- mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
-                          return ((f . R)  rs,
-                                  VRecType [(l, ty) | (l,t,ty) <- lttys]
-                                 )
-    ty              -> do lttys <- inferRecFields ge scope rs
-                          t <- liftM (f . R) (mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys)
-                          let ty' = VRecType [(l, ty) | (l,t,ty) <- lttys]
-                          t <- subsCheckRho ge scope t ty' ty
-                          return (t, ty')
-tcRho ge scope (P t l) mb_ty = do
-  l_ty   <- case mb_ty of
-              Just ty -> return ty
-              Nothing -> do i <- newMeta scope vtypeType
-                            return (VMeta i (scopeEnv scope) [])
-  (t,t_ty) <- tcRho ge scope t (Just (VRecType [(l,l_ty)]))
-  return (P t l,l_ty)
-tcRho ge scope (C t1 t2) mb_ty = do
-  (t1,t1_ty) <- tcRho ge scope t1 (Just vtypeStr)
-  (t2,t2_ty) <- tcRho ge scope t2 (Just vtypeStr)
-  instSigma ge scope (C t1 t2) vtypeStr mb_ty
-tcRho ge scope (Glue t1 t2) mb_ty = do
-  (t1,t1_ty) <- tcRho ge scope t1 (Just vtypeStr)
-  (t2,t2_ty) <- tcRho ge scope t2 (Just vtypeStr)
-  instSigma ge scope (Glue t1 t2) vtypeStr mb_ty
-tcRho ge scope t@(ExtR t1 t2) mb_ty = do
-  (t1,t1_ty) <- tcRho ge scope t1 Nothing
-  (t2,t2_ty) <- tcRho ge scope t2 Nothing
-  case (t1_ty,t2_ty) of
-    (VSort s1,VSort s2)
-       | (s1 == cType || s1 == cPType) &&
-         (s2 == cType || s2 == cPType) -> let sort | s1 == cPType && s2 == cPType = cPType
-                                                   | otherwise                    = cType
-                                          in instSigma ge scope (ExtR t1 t2) (VSort sort) mb_ty
-    (VRecType rs1, VRecType rs2)       -> instSigma ge scope (ExtR t1 t2) (VRecType (rs2++rs1)) mb_ty
-    _                                  -> tcError ("Cannot type check" <+> ppTerm Unqualified 0 t)
-tcRho ge scope (ELin cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
-  tcRho ge scope (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty
-tcRho ge scope (ELincat cat t) mb_ty = do  -- this could be done earlier, i.e. in the parser
-  tcRho ge scope (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty
-tcRho ge scope (Alts t ss) mb_ty = do
-  (t,_) <- tcRho ge scope t (Just vtypeStr)
-  ss    <- flip mapM ss $ \(t1,t2) -> do
-              (t1,_) <- tcRho ge scope t1 (Just vtypeStr)
-              (t2,_) <- tcRho ge scope t2 (Just vtypeStrs)
-              return (t1,t2)
-  instSigma ge scope (Alts t ss) vtypeStr mb_ty
-tcRho ge scope (Strs ss) mb_ty = do
-  ss <- flip mapM ss $ \t -> do
-           (t,_) <- tcRho ge scope t (Just vtypeStr)
-           return t
-  instSigma ge scope (Strs ss) vtypeStrs mb_ty
-tcRho ge scope (EPattType ty) mb_ty = do
-  (ty, _) <- tcRho ge scope ty (Just vtypeType)
-  instSigma ge scope (EPattType ty) vtypeType mb_ty
-tcRho ge scope t@(EPatt p) mb_ty = do
-  (scope,f,ty) <- case mb_ty of
-                    Nothing -> do i <- newMeta scope vtypeType
-                                  return (scope,id,VMeta i (scopeEnv scope) [])
-                    Just ty -> do (scope,f,ty) <- skolemise ge scope ty
-                                  case ty of
-                                    VPattType ty -> return (scope,f,ty)
-                                    _            -> tcError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
-  tcPatt ge scope p ty
-  return (f (EPatt p), ty)
-tcRho gr scope t _ = unimplemented ("tcRho "++show t)
-
-tcCases ge scope []         p_ty mb_res_ty = return ([],mb_res_ty)
-tcCases ge scope ((p,t):cs) p_ty mb_res_ty = do
-  scope' <- tcPatt ge scope p p_ty
-  (t,res_ty)     <- tcRho ge scope' t mb_res_ty
-  (cs,mb_res_ty) <- tcCases ge scope cs p_ty (Just res_ty)
-  return ((p,t):cs,mb_res_ty)
-
-
-tcApp ge scope t@(App fun (ImplArg arg)) = do                   -- APP1
-  tcApp ge scope fun `bindTcA` \(fun,fun_ty) ->
-     do (bt, arg_ty, res_ty) <- unifyFun ge scope fun_ty
-        if (bt == Implicit)
-          then return ()
-          else tcError (ppTerm Unqualified 0 t <+> "is an implicit argument application, but no implicit argument is expected")
-        (arg,_) <- tcRho ge scope arg (Just arg_ty)
-        varg <- liftErr (eval ge (scopeEnv scope) arg)
-        return (App fun (ImplArg arg), res_ty varg)
-tcApp ge scope (App fun arg) =                                  -- APP2
-  tcApp ge scope fun `bindTcA` \(fun,fun_ty) ->
-     do (fun,fun_ty) <- instantiate scope fun fun_ty
-        (_, arg_ty, res_ty) <- unifyFun ge scope fun_ty
-        (arg,_) <- tcRho ge scope arg (Just arg_ty)
-        varg <- liftErr (eval ge (scopeEnv scope) arg)
-        return (App fun arg, res_ty varg)
-tcApp ge scope (Q id) =                                          -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
-     do ty <- liftErr (eval ge [] ty)
-        return (t,ty)
-tcApp ge scope (QC id) =                                         -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
-     do ty <- liftErr (eval ge [] ty)
-        return (t,ty)
-tcApp ge scope t =
-  singleTcA (tcRho ge scope t Nothing)
-
-
-tcOverloadFailed t ttys =
-  tcError ("Overload resolution failed" $$
-           "of term   " <+> pp t $$
-           "with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys])
-
-
-tcPatt ge scope PW        ty0 =
-  return scope
-tcPatt ge scope (PV x)    ty0 =
-  return ((x,ty0):scope)
-tcPatt ge scope (PP c ps) ty0 =
-  case lookupResType (geGrammar ge) c of
-    Ok ty  -> do let go scope ty []     = return (scope,ty)
-                     go scope ty (p:ps) = do (_,arg_ty,res_ty) <- unifyFun ge scope ty
-                                             scope <- tcPatt ge scope p arg_ty
-                                             go scope (res_ty (VGen (length scope) [])) ps
-                 vty <- liftErr (eval ge [] ty)
-                 (scope,ty) <- go scope vty ps
-                 unify ge scope ty0 ty
-                 return scope
-    Bad err -> tcError (pp err)
-tcPatt ge scope (PInt i) ty0 = do
-  subsCheckRho ge scope (EInt i) (vtypeInts i) ty0
-  return scope
-tcPatt ge scope (PString s) ty0 = do
-  unify ge scope ty0 vtypeStr
-  return scope
-tcPatt ge scope PChar ty0 = do
-  unify ge scope ty0 vtypeStr
-  return scope
-tcPatt ge scope (PSeq p1 p2) ty0 = do
-  unify ge scope ty0 vtypeStr
-  scope <- tcPatt ge scope p1 vtypeStr
-  scope <- tcPatt ge scope p2 vtypeStr
-  return scope
-tcPatt ge scope (PAs x p) ty0 = do
-  tcPatt ge ((x,ty0):scope) p ty0
-tcPatt ge scope (PR rs) ty0 = do
-  let mk_ltys  []            = return []
-      mk_ltys  ((l,p):rs)    = do i <- newMeta scope vtypePType
-                                  ltys <- mk_ltys rs
-                                  return ((l,p,VMeta i (scopeEnv scope) []) : ltys)
-      go scope []            = return scope
-      go scope ((l,p,ty):rs) = do scope <- tcPatt ge scope p ty
-                                  go scope rs
-  ltys <- mk_ltys rs
-  subsCheckRho ge scope (EPatt (PR rs)) (VRecType [(l,ty) | (l,p,ty) <- ltys]) ty0
-  go scope ltys
-tcPatt ge scope (PAlt p1 p2) ty0 = do
-  tcPatt ge scope p1 ty0
-  tcPatt ge scope p2 ty0
-  return scope
-tcPatt ge scope (PM q) ty0 = do
-  case lookupResType (geGrammar ge) q of
-    Ok (EPattType ty)
-            -> do vty <- liftErr (eval ge [] ty)
-                  unify ge scope ty0 vty
-                  return scope
-    Ok ty   -> tcError ("Pattern type expected but " <+> pp ty <+> " found.")
-    Bad err -> tcError (pp err)
-tcPatt ge scope p ty = unimplemented ("tcPatt "++show p)
-
-inferRecFields ge scope rs =
-  mapM (\(l,r) -> tcRecField ge scope l r Nothing) rs
-
-checkRecFields ge scope []          ltys
-  | null ltys                            = return []
-  | otherwise                            = tcError ("Missing fields:" <+> hsep (map fst ltys))
-checkRecFields ge scope ((l,t):lts) ltys =
-  case takeIt l ltys of
-    (Just ty,ltys) -> do ltty  <- tcRecField ge scope l t (Just ty)
-                         lttys <- checkRecFields ge scope lts ltys
-                         return (ltty : lttys)
-    (Nothing,ltys) -> do tcWarn ("Discarded field:" <+> l)
-                         ltty  <- tcRecField ge scope l t Nothing
-                         lttys <- checkRecFields ge scope lts ltys
-                         return lttys     -- ignore the field
-  where
-    takeIt l1 []  = (Nothing, [])
-    takeIt l1 (lty@(l2,ty):ltys)
-      | l1 == l2  = (Just ty,ltys)
-      | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
-                    in (mb_ty,lty:ltys')
-
-tcRecField ge scope l (mb_ann_ty,t) mb_ty = do
-  (t,ty) <- case mb_ann_ty of
-              Just ann_ty -> do (ann_ty, _) <- tcRho ge scope ann_ty (Just vtypeType)
-                                v_ann_ty <- liftErr (eval ge (scopeEnv scope) ann_ty)
-                                (t,_) <- tcRho ge scope t (Just v_ann_ty)
-                                instSigma ge scope t v_ann_ty mb_ty
-              Nothing     -> tcRho ge scope t mb_ty
-  return (l,t,ty)
-
-tcRecTypeFields ge scope []          mb_ty = return ([],mb_ty)
-tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
-  (ty,sort) <- tcRho ge scope ty mb_ty
-  mb_ty <- case sort of
-             VSort s
-               | s == cType  -> return (Just sort)
-               | s == cPType -> return mb_ty
-             VMeta _ _ _     -> return mb_ty
-             _               -> do sort <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) sort
-                                   tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
-                                            "cannot be of type" <+> ppTerm Unqualified 0 sort)
-  (rs,mb_ty) <- tcRecTypeFields ge scope rs mb_ty
-  return ((l,ty):rs,mb_ty)
-
--- | Invariant: if the third argument is (Just rho),
---              then rho is in weak-prenex form
-instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
-instSigma ge scope t ty1 Nothing    = return (t,ty1)           -- INST1
-instSigma ge scope t ty1 (Just ty2) = do                       -- INST2
-  t <- subsCheckRho ge scope t ty1 ty2
-  return (t,ty2)
-
--- | Invariant: the second argument is in weak-prenex form
-subsCheckRho :: GlobalEnv -> Scope -> Term -> Sigma -> Rho -> TcM Term
-subsCheckRho ge scope t ty1@(VMeta i env vs) ty2 = do
-  mv <- getMeta i
-  case mv of
-    Unbound _ _ -> do unify ge scope ty1 ty2
-                      return t
-    Bound ty1   -> do vty1 <- liftErr (eval ge env ty1)
-                      subsCheckRho ge scope t (vapply (geLoc ge) vty1 vs) ty2
-subsCheckRho ge scope t ty1 ty2@(VMeta i env vs) = do
-  mv <- getMeta i
-  case mv of
-    Unbound _ _ -> do unify ge scope ty1 ty2
-                      return t
-    Bound ty2   -> do vty2 <- liftErr (eval ge env ty2)
-                      subsCheckRho ge scope t ty1 (vapply (geLoc ge) vty2 vs)
-subsCheckRho ge scope t (VProd Implicit ty1 x (Bind ty2)) rho2 = do     -- Rule SPEC
-  i <- newMeta scope ty1
-  subsCheckRho ge scope (App t (ImplArg (Meta i))) (ty2 (VMeta i [] [])) rho2
-subsCheckRho ge scope t rho1 (VProd Implicit ty1 x (Bind ty2)) = do     -- Rule SKOL
-  let v = newVar scope
-  t <- subsCheckRho ge ((v,ty1):scope) t rho1 (ty2 (VGen (length scope) []))
-  return (Abs Implicit v t)
-subsCheckRho ge scope t rho1 (VProd Explicit a2 _ (Bind r2)) = do       -- Rule FUN
-  (_,a1,r1) <- unifyFun ge scope rho1
-  subsCheckFun ge scope t a1 r1 a2 r2
-subsCheckRho ge scope t (VProd Explicit a1 _ (Bind r1)) rho2 = do       -- Rule FUN
-  (bt,a2,r2) <- unifyFun ge scope rho2
-  subsCheckFun ge scope t a1 r1 a2 r2
-subsCheckRho ge scope t rho1 (VTblType p2 r2) = do                      -- Rule TABLE
-  (p1,r1) <- unifyTbl ge scope rho1
-  subsCheckTbl ge scope t p1 r1 p2 r2
-subsCheckRho ge scope t (VTblType p1 r1) rho2 = do                      -- Rule TABLE
-  (p2,r2) <- unifyTbl ge scope rho2
-  subsCheckTbl ge scope t p1 r1 p2 r2
-subsCheckRho ge scope t (VSort s1) (VSort s2)                           -- Rule PTYPE
-  | s1 == cPType && s2 == cType = return t
-subsCheckRho ge scope t (VApp p1 _) (VApp p2 _)                         -- Rule INT1
-  | predefName p1 == cInts && predefName p2 == cInt = return t
-subsCheckRho ge scope t (VApp p1 [VInt i]) (VApp p2 [VInt j])           -- Rule INT2
-  | predefName p1 == cInts && predefName p2 == cInts =
-      if i <= j
-        then return t
-        else tcError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
-subsCheckRho ge scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
-  let mkAccess scope t =
-        case t of
-          ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
-                           (scope,mkProj2,mkWrap2) <- mkAccess scope t2
-                           return (scope
-                                  ,\l -> mkProj2 l `mplus` mkProj1 l
-                                  ,mkWrap1 . mkWrap2
-                                  )
-          R rs -> do sequence_ [tcWarn ("Discarded field:" <+> l) | (l,_) <- rs, isNothing (lookup l rs2)]
-                     return (scope
-                            ,\l -> lookup l rs
-                            ,id
-                            )
-          Vr x -> do return (scope
-                            ,\l -> do VRecType rs <- lookup x scope
-                                      ty <- lookup l rs
-                                      return (Nothing,P t l)
-                            ,id
-                            )
-          t    -> let x = newVar scope
-                  in return (((x,ty1):scope)
-                            ,\l  -> return (Nothing,P (Vr x) l)
-                            ,Let (x, (Nothing, t))
-                            )
-
-      mkField scope l (mb_ty,t) ty1 ty2 = do
-        t <- subsCheckRho ge scope t ty1 ty2
-        return (l, (mb_ty,t))
-
-  (scope,mkProj,mkWrap) <- mkAccess scope t
-
-  let fields = [(l,ty2,lookup l rs1) | (l,ty2) <- rs2]
-  case [l | (l,_,Nothing) <- fields] of
-    []      -> return ()
-    missing -> tcError ("In the term" <+> pp t $$
-                        "there are no values for fields:" <+> hsep missing)
-  rs <- sequence [mkField scope l t ty1 ty2 | (l,ty2,Just ty1) <- fields, Just t <- [mkProj l]]
-  return (mkWrap (R rs))
-subsCheckRho ge scope t tau1 tau2 = do                                  -- Rule EQ
-  unify ge scope tau1 tau2                                 -- Revert to ordinary unification
-  return t
-
-subsCheckFun :: GlobalEnv -> Scope -> Term -> Sigma -> (Value -> Rho) -> Sigma -> (Value -> Rho) -> TcM Term
-subsCheckFun ge scope t a1 r1 a2 r2 = do
-  let v   = newVar scope
-  vt <- subsCheckRho ge ((v,a2):scope) (Vr v) a2 a1
-  val1 <- liftErr (eval ge (scopeEnv ((v,vtypeType):scope)) vt)
-  val2 <- return  (VGen (length scope) [])
-  t  <- subsCheckRho ge ((v,vtypeType):scope) (App t vt) (r1 val1) (r2 val2)
-  return (Abs Explicit v t)
-
-subsCheckTbl :: GlobalEnv -> Scope -> Term -> Sigma -> Rho -> Sigma -> Rho -> TcM Term
-subsCheckTbl ge scope t p1 r1 p2 r2 = do
-  let x = newVar scope
-  xt <- subsCheckRho ge scope (Vr x) p2 p1
-  t  <- subsCheckRho ge ((x,vtypePType):scope) (S t xt) r1 r2 ;
-  p2 <- tc_value2term (geLoc ge) (scopeVars scope) p2
-  return (T (TTyped p2) [(PV x,t)])
-
------------------------------------------------------------------------
--- Unification
------------------------------------------------------------------------
-
-unifyFun :: GlobalEnv -> Scope -> Rho -> TcM (BindType, Sigma, Value -> Rho)
-unifyFun ge scope (VProd bt arg x (Bind res)) =
-  return (bt,arg,res)
-unifyFun ge scope tau = do
-  let mk_val ty = VMeta ty [] []
-  arg <- fmap mk_val $ newMeta scope vtypeType
-  res <- fmap mk_val $ newMeta scope vtypeType
-  let bt = Explicit
-  unify ge scope tau (VProd bt arg identW (Bind (const res)))
-  return (bt,arg,const res)
-
-unifyTbl :: GlobalEnv -> Scope -> Rho -> TcM (Sigma, Rho)
-unifyTbl ge scope (VTblType arg res) =
-  return (arg,res)
-unifyTbl ge scope tau = do
-  let mk_val ty = VMeta ty (scopeEnv scope) []
-  arg <- fmap mk_val $ newMeta scope vtypePType
-  res <- fmap mk_val $ newMeta scope vtypeType
-  unify ge scope tau (VTblType arg res)
-  return (arg,res)
-
-unify ge scope (VApp f1 vs1)      (VApp f2 vs2)
-  | f1 == f2                   = sequence_ (zipWith (unify ge scope) vs1 vs2)
-unify ge scope (VCApp f1 vs1)     (VCApp f2 vs2)
-  | f1 == f2                   = sequence_ (zipWith (unify ge scope) vs1 vs2)
-unify ge scope (VSort s1)         (VSort s2)
-  | s1 == s2                   = return ()
-unify ge scope (VGen i vs1)       (VGen j vs2)
-  | i == j                     = sequence_ (zipWith (unify ge scope) vs1 vs2)
-unify ge scope (VTblType p1 res1) (VTblType p2 res2) = do
-  unify ge scope p1   p2
-  unify ge scope res1 res2
-unify ge scope (VMeta i env1 vs1) (VMeta j env2 vs2)
-  | i  == j                    = sequence_ (zipWith (unify ge scope) vs1 vs2)
-  | otherwise                  = do mv <- getMeta j
-                                    case mv of
-                                      Bound t2    -> do v2 <- liftErr (eval ge env2 t2)
-                                                        unify ge scope (VMeta i env1 vs1) (vapply (geLoc ge) v2 vs2)
-                                      Unbound _ _ -> setMeta i (Bound (Meta j))
-unify ge scope (VInt i)       (VInt j)
-  | i == j                     = return ()
-unify ge scope (VMeta i env vs) v = unifyVar ge scope i env vs v
-unify ge scope v (VMeta i env vs) = unifyVar ge scope i env vs v
-unify ge scope v1 v2 = do
-  t1 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v1
-  t2 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v2
-  tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$
-                                      ppTerm Unqualified 0 t2))
-
--- | Invariant: tv1 is a flexible type variable
-unifyVar :: GlobalEnv -> Scope -> MetaId -> Env -> [Value] -> Tau -> TcM ()
-unifyVar ge scope i env vs ty2 = do            -- Check whether i is bound
-  mv <- getMeta i
-  case mv of
-    Bound ty1       -> do v <- liftErr (eval ge env ty1)
-                          unify ge scope (vapply (geLoc ge) v vs) ty2
-    Unbound scope' _ -> case value2term (geLoc ge) (scopeVars scope') ty2 of
-                          -- Left i     -> let (v,_) = reverse scope !! i
-                          --               in tcError ("Variable" <+> pp v <+> "has escaped")
-                                ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
-                                           if i `elem` ms2
-                                             then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
-                                                           nest 2 (ppTerm Unqualified 0 ty2'))
-                                             else setMeta i (Bound ty2')
-
------------------------------------------------------------------------
--- Instantiation and quantification
------------------------------------------------------------------------
-
--- | Instantiate the topmost implicit arguments with metavariables
-instantiate :: Scope -> Term -> Sigma -> TcM (Term,Rho)
-instantiate scope t (VProd Implicit ty1 x (Bind ty2)) = do
-  i <- newMeta scope ty1
-  instantiate scope (App t (ImplArg (Meta i))) (ty2 (VMeta i [] []))
-instantiate scope t ty = do
-  return (t,ty)
-
--- | Build fresh lambda abstractions for the topmost implicit arguments
-skolemise :: GlobalEnv -> Scope -> Sigma -> TcM (Scope, Term->Term, Rho)
-skolemise ge scope ty@(VMeta i env vs) = do
-  mv <- getMeta i
-  case mv of
-    Unbound _ _ -> return (scope,id,ty)                   -- guarded constant?
-    Bound ty    -> do vty <- liftErr (eval ge env ty)
-                      skolemise ge scope (vapply (geLoc ge) vty vs)
-skolemise ge scope (VProd Implicit ty1 x (Bind ty2)) = do
-  let v = newVar scope
-  (scope,f,ty2) <- skolemise ge ((v,ty1):scope) (ty2 (VGen (length scope) []))
-  return (scope,Abs Implicit v . f,ty2)
-skolemise ge scope ty = do
-  return (scope,id,ty)
-
--- | Quantify over the specified type variables (all flexible)
-quantify :: GlobalEnv -> Scope -> Term -> [MetaId] -> Rho -> TcM (Term,Sigma)
-quantify ge scope t tvs ty0 = do
-  ty <- tc_value2term (geLoc ge) (scopeVars scope) ty0
-  let used_bndrs = nub (bndrs ty)  -- Avoid quantified type variables in use
-      new_bndrs  = take (length tvs) (allBinders \\ used_bndrs)
-  mapM_ bind (tvs `zip` new_bndrs)   -- 'bind' is just a cunning way
-  ty <- zonkTerm ty                  -- of doing the substitution
-  vty <- liftErr (eval ge [] (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs))
-  return (foldr (Abs Implicit) t new_bndrs,vty)
-  where
-    bind (i, name) = setMeta i (Bound (Vr name))
-
-    bndrs (Prod _ x t1 t2) = [x] ++ bndrs t1  ++ bndrs t2
-    bndrs _                = []
-
-allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,...
-allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
-             [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
-
-
------------------------------------------------------------------------
--- The Monad
------------------------------------------------------------------------
-
-type Scope = [(Ident,Value)]
-
-type Sigma = Value
-type Rho   = Value -- No top-level ForAll
-type Tau   = Value -- No ForAlls anywhere
-
-data MetaValue
-  = Unbound Scope Sigma
-  | Bound   Term
-type MetaStore = IntMap.IntMap MetaValue
-data TcResult a
-  = TcOk   a MetaStore [Message]
-  | TcFail             [Message] -- First msg is error, the rest are warnings?
-newtype TcM a = TcM {unTcM :: MetaStore -> [Message] -> TcResult a}
-
-instance Monad TcM where
-  return = pure
-  f >>= g  = TcM (\ms msgs -> case unTcM f ms msgs of
-                                TcOk x ms msgs -> unTcM (g x) ms msgs
-                                TcFail    msgs -> TcFail msgs)
-
-#if !(MIN_VERSION_base(4,13,0))
-  -- Monad(fail) will be removed in GHC 8.8+
-  fail = Fail.fail
-#endif
-
-instance Fail.MonadFail TcM where
-  fail     = tcError . pp
-
-
-instance Applicative TcM where
-  pure x = TcM (\ms msgs -> TcOk x ms msgs)
-  (<*>) = ap
-
-instance Functor TcM where
-  fmap f g = TcM (\ms msgs -> case unTcM g ms msgs of
-                           TcOk x ms msgs -> TcOk (f x) ms msgs
-                           TcFail msgs    -> TcFail msgs)
-
-instance ErrorMonad TcM where
-  raise  = tcError . pp
-  handle f g = TcM (\ms msgs -> case unTcM f ms msgs of
-                                  TcFail (msg:msgs) -> unTcM (g (render msg)) ms msgs
-                                  r                 -> r)
-
-tcError :: Message -> TcM a
-tcError msg = TcM (\ms msgs -> TcFail (msg : msgs))
-
-tcWarn :: Message -> TcM ()
-tcWarn msg = TcM (\ms msgs -> TcOk () ms (msg : msgs))
-
-unimplemented str = fail ("Unimplemented: "++str)
-
-
-runTcM :: TcM a -> Check a
-runTcM f = case unTcM f IntMap.empty [] of
-             TcOk x _ msgs -> do checkWarnings msgs; return x
-             TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg
-
-newMeta :: Scope -> Sigma -> TcM MetaId
-newMeta scope ty = TcM (\ms msgs ->
-  let i = IntMap.size ms
-  in TcOk i (IntMap.insert i (Unbound scope ty) ms) msgs)
-
-getMeta :: MetaId -> TcM MetaValue
-getMeta i = TcM (\ms msgs ->
-  case IntMap.lookup i ms of
-    Just mv -> TcOk mv ms msgs
-    Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs))
-
-setMeta :: MetaId -> MetaValue -> TcM ()
-setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)
-
-newVar :: Scope -> Ident
-newVar scope = head [x | i <- [1..],
-                         let x = identS ('v':show i),
-                         isFree scope x]
-  where
-    isFree []            x = True
-    isFree ((y,_):scope) x = x /= y && isFree scope x
-
-scopeEnv   scope = zipWith (\(x,ty) i -> (x,VGen i [])) (reverse scope) [0..]
-scopeVars  scope = map fst scope
-scopeTypes scope = zipWith (\(_,ty) scope -> (scope,ty)) scope (tails scope)
-
--- | This function takes account of zonking, and returns a set
--- (no duplicates) of unbound meta-type variables
-getMetaVars :: GLocation -> [(Scope,Sigma)] -> TcM [MetaId]
-getMetaVars loc sc_tys = do
-  tys <- mapM (\(scope,ty) -> zonkTerm =<< tc_value2term loc (scopeVars scope) ty) sc_tys
-  return (foldr go [] tys)
-  where
-    -- Get the MetaIds from a term; no duplicates in result
-    go (Vr tv)    acc = acc
-    go (App x y)  acc = go x (go y acc)
-    go (Meta i)   acc
-      | i `elem` acc  = acc
-      | otherwise     = i : acc
-    go (Q _)      acc = acc
-    go (QC _)     acc = acc
-    go (Sort _)   acc = acc
-    go (Prod _ _ arg res) acc = go arg (go res acc)
-    go (Table p t) acc = go p (go t acc)
-    go (RecType rs) acc = foldl (\acc (l,ty) -> go ty acc) acc rs
-    go t acc = unimplemented ("go "++show t)
-
--- | This function takes account of zonking, and returns a set
--- (no duplicates) of free type variables
-getFreeVars :: GLocation -> [(Scope,Sigma)] -> TcM [Ident]
-getFreeVars loc sc_tys = do
-  tys <- mapM (\(scope,ty) -> zonkTerm =<< tc_value2term loc (scopeVars scope) ty) sc_tys
-  return (foldr (go []) [] tys)
-  where
-    go bound (Vr tv)            acc
-      | tv `elem` bound             = acc
-      | tv `elem` acc               = acc
-      | otherwise                   = tv : acc
-    go bound (App x y)          acc = go bound x (go bound y acc)
-    go bound (Meta _)           acc = acc
-    go bound (Q _)              acc = acc
-    go bound (QC _)             acc = acc
-    go bound (Prod _ x arg res) acc = go bound arg (go (x : bound) res acc)
-    go bound (RecType rs) acc = foldl (\acc (l,ty) -> go bound ty acc) acc rs
-    go bound (Table p t)        acc = go bound p (go bound t acc)
-
--- | Eliminate any substitutions in a term
-zonkTerm :: Term -> TcM Term
-zonkTerm (Meta i) = do
-  mv <- getMeta i
-  case mv of
-    Unbound _ _ -> return (Meta i)
-    Bound t     -> do t <- zonkTerm t
-                      setMeta i (Bound t)       -- "Short out" multiple hops
-                      return t
-zonkTerm t = composOp zonkTerm t
-
-tc_value2term loc xs v =
-  return $ value2term loc xs v
-    -- Old value2term error message:
-    -- Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
-
-
-
-data TcA x a
-  = TcSingle   (MetaStore -> [Message] -> TcResult a)
-  | TcMany [x] (MetaStore -> [Message] -> [(a,MetaStore,[Message])])
-
-mkTcA :: Err [a] -> TcA a a
-mkTcA f = case f of
-            Bad msg -> TcSingle  (\ms msgs -> TcFail (pp msg : msgs))
-            Ok  [x] -> TcSingle  (\ms msgs -> TcOk x ms msgs)
-            Ok  xs  -> TcMany xs (\ms msgs -> [(x,ms,msgs) | x <- xs])
-
-singleTcA :: TcM a -> TcA x a
-singleTcA = TcSingle . unTcM
-
-bindTcA :: TcA x a -> (a -> TcM b) -> TcA x b
-bindTcA f g = case f of
-                TcSingle  f -> TcSingle (unTcM (TcM f >>= g))
-                TcMany xs f -> TcMany xs (\ms msgs -> foldr add [] (f ms msgs))
-  where
-    add (y,ms,msgs) rs =
-      case unTcM (g y) ms msgs of
-        TcFail _       -> rs
-        TcOk y ms msgs -> (y,ms,msgs):rs
-
-runTcA :: ([x] -> TcM a) -> TcA x a -> TcM a
-runTcA g f = TcM (\ms msgs -> case f of
-                                TcMany xs f -> case f ms msgs of
-                                                 [(x,ms,msgs)] -> TcOk x ms msgs
-                                                 rs            -> unTcM (g xs) ms msgs
-                                TcSingle f                     -> f ms msgs)

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

@@ -1,68 +0,0 @@
-module GF.Compile.TypeCheck.Primitives where
-
-import GF.Grammar
-import GF.Grammar.Predef
-import qualified Data.Map as Map
-
-typPredefined :: Ident -> Maybe Type
-typPredefined f = case Map.lookup f primitives of
-                    Just (ResOper (Just (L _ ty)) _) -> Just ty
-                    Just (ResParam _ _)              -> Just typePType
-                    Just (ResValue (L _ ty))         -> Just ty
-                    _                                -> Nothing
-
-primitives = Map.fromList
-  [ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
-  , (cInt      , ResOper (Just (noLoc typePType)) Nothing)
-  , (cFloat    , ResOper (Just (noLoc typePType)) Nothing)
-  , (cInts     , fun [typeInt] typePType)
-  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
-  , (cPTrue    , ResValue (noLoc typePBool))
-  , (cPFalse   , ResValue (noLoc typePBool))
-  , (cError    , fun [typeStr] typeError)  -- non-can. of empty set
-  , (cLength   , fun [typeTok] typeInt)
-  , (cDrop     , fun [typeInt,typeTok] typeTok)
-  , (cTake     , fun [typeInt,typeTok] typeTok)
-  , (cTk       , fun [typeInt,typeTok] typeTok)
-  , (cDp       , fun [typeInt,typeTok] typeTok)
-  , (cEqInt    , fun [typeInt,typeInt] typePBool)
-  , (cLessInt  , fun [typeInt,typeInt] typePBool)
-  , (cPlus     , fun [typeInt,typeInt] typeInt)
-  , (cEqStr    , fun [typeTok,typeTok] typePBool)
-  , (cOccur    , fun [typeTok,typeTok] typePBool)
-  , (cOccurs   , fun [typeTok,typeTok] typePBool)
-
-  , (cToUpper  , fun [typeTok] typeTok)
-  , (cToLower  , fun [typeTok] typeTok)
-  , (cIsUpper  , fun [typeTok] typePBool)
-
-----  "read"   -> 
-  , (cRead     , ResOper (Just (noLoc (mkProd -- (P : Type) -> Tok -> P
-                                         [(Explicit,varP,typePType),(Explicit,identW,typeStr)] (Vr varP) []))) Nothing)
-  , (cShow     , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> Tok
-                                         [(Explicit,varP,typePType),(Explicit,identW,Vr varP)] typeStr []))) Nothing)
-  , (cEqVal    , ResOper (Just (noLoc (mkProd -- (P : PType) -> P -> P -> PBool
-                                         [(Explicit,varP,typePType),(Explicit,identW,Vr varP),(Explicit,identW,Vr varP)] typePBool []))) Nothing)
-  , (cToStr    , ResOper (Just (noLoc (mkProd -- (L : Type)  -> L -> Str
-                                         [(Explicit,varL,typeType),(Explicit,identW,Vr varL)] typeStr []))) Nothing)
-  , (cMapStr   , ResOper (Just (noLoc (mkProd -- (L : Type)  -> (Str -> Str) -> L -> L
-                                         [(Explicit,varL,typeType),(Explicit,identW,mkFunType [typeStr] typeStr),(Explicit,identW,Vr varL)] (Vr varL) []))) Nothing)
-  , (cNonExist , ResOper (Just (noLoc (mkProd -- Str
-                                         [] typeStr []))) Nothing)
-  , (cBIND     , ResOper (Just (noLoc (mkProd -- Str
-                                         [] typeStr []))) Nothing)
-  , (cSOFT_BIND, ResOper (Just (noLoc (mkProd -- Str
-                                         [] typeStr []))) Nothing)
-  , (cSOFT_SPACE,ResOper (Just (noLoc (mkProd -- Str
-                                         [] typeStr []))) Nothing)
-  , (cCAPIT    , ResOper (Just (noLoc (mkProd -- Str
-                                         [] typeStr []))) Nothing)
-  , (cALL_CAPIT, ResOper (Just (noLoc (mkProd -- Str
-                                         [] typeStr []))) Nothing)
-  ]
-  where
-    fun from to = oper (mkFunType from to)
-    oper ty     = ResOper (Just (noLoc ty)) Nothing
-
-    varL = identS "L"
-    varP = identS "P"

src/compiler/GF/Data/XML.hs

@@ -1,57 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : XML
---
--- Utilities for creating XML documents.
-----------------------------------------------------------------------
-module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
-
-import GF.Data.Utilities
-
-data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
- deriving (Ord,Eq,Show)
-
-type Attr = (String,String)
-
-comments :: [String] -> [XML]
-comments = map Comment
-
-showXMLDoc :: XML -> String
-showXMLDoc xml = showsXMLDoc xml ""
-
-showsXMLDoc :: XML -> ShowS
-showsXMLDoc xml = showString header . showsXML xml
-  where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
-
-showsXML :: XML -> ShowS
-showsXML = showsX 0 where
-  showsX i x = ind i . case x of
-    (Data s) -> showString s
-    (CData s) -> showString "<![CDATA[" . showString s .showString "]]>"
-    (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>"
-    (Tag t as cs) -> 
-      showChar '<' . showString t . showsAttrs as . showChar '>' . 
-      concatS (map (showsX (i+1)) cs) . ind i . 
-      showString "</" . showString t . showChar '>'
-    (Comment c) -> showString "<!-- " . showString c . showString " -->"
-    (Empty) -> id
-  ind i = showString ("\n" ++ replicate (2*i) ' ')
-
-showsAttrs :: [Attr] -> ShowS
-showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
-
-showsAttr :: Attr -> ShowS
-showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
-
-escape :: String -> String
-escape = concatMap escChar
-  where
-  escChar '<'  = "&lt;"
-  escChar '>'  = "&gt;"
-  escChar '&'  = "&amp;"
-  escChar '"'  = "&quot;"
-  escChar c    = [c]
-
-bottomUpXML :: (XML -> XML) -> XML -> XML
-bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
-bottomUpXML f x = f x

src/compiler/GF/Grammar/Canonical.hs

@@ -1,313 +0,0 @@
--- |
--- Module    :  GF.Grammar.Canonical
--- Stability :  provisional
---
--- Abstract syntax for canonical GF grammars, i.e. what's left after
--- high-level constructions such as functors and opers have been eliminated
--- by partial evaluation. This is intended as a common intermediate
--- representation to simplify export to other formats.
-
-{-# LANGUAGE DeriveTraversable #-}
-module GF.Grammar.Canonical where
-import Prelude hiding ((<>))
-import GF.Text.Pretty
-import GF.Infra.Ident (RawIdent)
-
--- | A Complete grammar
-data Grammar = Grammar Abstract [Concrete] deriving Show
-
---------------------------------------------------------------------------------
--- ** Abstract Syntax
-
--- | Abstract Syntax
-data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
-abstrName (Abstract mn _ _ _) = mn
-
-data CatDef   = CatDef CatId [CatId]        deriving Show
-data FunDef   = FunDef FunId Type           deriving Show
-data Type     = Type [TypeBinding] TypeApp  deriving Show
-data TypeApp  = TypeApp CatId [Type]        deriving Show
-
-data TypeBinding = TypeBinding VarId Type   deriving Show
-
---------------------------------------------------------------------------------
--- ** Concreate syntax
-
--- | Concrete Syntax
-data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
-                 deriving Show
-concName (Concrete cnc _ _ _ _ _) = cnc
-
-data ParamDef  = ParamDef ParamId [ParamValueDef]
-               | ParamAliasDef ParamId LinType
-               deriving Show
-data LincatDef = LincatDef CatId LinType  deriving Show
-data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
-
--- | Linearization type, RHS of @lincat@
-data LinType = FloatType
-             | IntType
-             | ParamType ParamType
-             | RecordType [RecordRowType]
-             | StrType
-             | TableType LinType LinType
-             | TupleType [LinType]
-              deriving (Eq,Ord,Show)
-
-newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
-
--- | Linearization value, RHS of @lin@
-data LinValue = ConcatValue LinValue LinValue
-              | LiteralValue LinLiteral
-              | ErrorValue String
-              | ParamConstant ParamValue
-              | PredefValue PredefId
-              | RecordValue [RecordRowValue]
-              | TableValue LinType [TableRowValue]
----           | VTableValue LinType [LinValue]
-              | TupleValue [LinValue]
-              | VariantValue [LinValue]
-              | VarValue VarValueId
-              | PreValue [([String], LinValue)] LinValue
-              | Projection LinValue LabelId
-              | Selection LinValue LinValue
-              | CommentedValue String LinValue
-              deriving (Eq,Ord,Show)
-
-data LinLiteral = FloatConstant Float
-                | IntConstant Int
-                | StrConstant String
-                deriving (Eq,Ord,Show)
-
-data LinPattern = ParamPattern ParamPattern
-                | RecordPattern [RecordRow LinPattern]
-                | TuplePattern [LinPattern]
-                | WildPattern
-                deriving (Eq,Ord,Show)
-
-type ParamValue = Param LinValue
-type ParamPattern = Param LinPattern
-type ParamValueDef = Param ParamId
-
-data Param arg = Param ParamId [arg]
-                 deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
-
-type RecordRowType  = RecordRow LinType
-type RecordRowValue = RecordRow LinValue
-type TableRowValue  = TableRow LinValue
-
-data RecordRow rhs = RecordRow LabelId    rhs
-                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
-data TableRow  rhs = TableRow  LinPattern rhs
-                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
-
--- *** Identifiers in Concrete Syntax
-
-newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
-newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
-data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
-
--- | Name of param type or param value
-newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
-
---------------------------------------------------------------------------------
--- ** Used in both Abstract and Concrete Syntax
-
-newtype ModId = ModId Id  deriving (Eq,Ord,Show)
-
-newtype CatId = CatId Id  deriving (Eq,Ord,Show)
-newtype FunId = FunId Id  deriving (Eq,Show)
-
-data VarId = Anonymous | VarId Id  deriving Show
-
-newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
-type FlagName = Id
-data FlagValue = Str String | Int Int | Flt Double deriving Show
-
-
--- *** Identifiers
-
-type Id = RawIdent
-data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
-
---------------------------------------------------------------------------------
--- ** Pretty printing
-
-instance Pretty Grammar where
-  pp (Grammar abs cncs) = abs $+$ vcat cncs
-
-instance Pretty Abstract where
-  pp (Abstract m flags cats funs) =
-    "abstract" <+> m <+> "=" <+> "{" $$
-       flags $$
-       "cat" <+> fsep cats $$
-       "fun" <+> vcat funs $$
-       "}"
-
-instance Pretty CatDef where
-  pp (CatDef c cs) = hsep (c:cs)<>";"
-
-instance Pretty FunDef where
-  pp (FunDef f ty) = f <+> ":" <+> ty <>";"
-
-instance Pretty Type where
-  pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
-
-instance PPA Type where
-  ppA (Type [] (TypeApp c [])) = pp c
-  ppA t = parens t
-
-instance Pretty TypeBinding where
-  pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
-  pp (TypeBinding Anonymous ty) = parens ty
-  pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
-
-instance Pretty TypeApp where
- pp (TypeApp c targs) = c<+>hsep (map ppA targs)
-
-instance Pretty VarId where
-  pp Anonymous = pp "_"
-  pp (VarId x) = pp x
-
---------------------------------------------------------------------------------
-
-instance Pretty Concrete where
-  pp (Concrete cncid absid flags params lincats lins) =
-      "concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
-      vcat params $$
-      section "lincat" lincats $$
-      section "lin" lins $$
-      "}"
-    where
-      section name [] = empty
-      section name ds = name <+> vcat (map (<> ";") ds)
-
-instance Pretty ParamDef where
-  pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
-  pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
-
-instance PPA arg => Pretty (Param arg) where
-  pp (Param p ps) = pp p<+>sep (map ppA ps)
-
-instance PPA arg => PPA (Param arg) where
-  ppA (Param p []) = pp p
-  ppA pv = parens pv
-
-instance Pretty LincatDef where
-  pp (LincatDef c lt) = hang (c <+> "=") 4 lt
-
-instance Pretty LinType where
- pp lt = case lt of
-           FloatType -> pp "Float"
-           IntType -> pp "Int"
-           ParamType pt -> pp pt
-           RecordType rs -> block rs
-           StrType -> pp "Str"
-           TableType pt lt -> sep [pt <+> "=>",pp lt]
-           TupleType lts -> "<"<>punctuate "," lts<>">"
-
-instance RhsSeparator LinType  where rhsSep _ = pp ":"
-
-instance Pretty ParamType where
-  pp (ParamTypeId p) = pp p
-
-instance Pretty LinDef where
-  pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
-
-instance Pretty LinValue where
-  pp lv = case lv of
-            ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
-            ErrorValue s -> "Predef.error"<+>doubleQuotes s
-            ParamConstant pv -> pp pv
-            Projection lv l -> ppA lv<>"."<>l
-            Selection tv pv -> ppA tv<>"!"<>ppA pv
-            VariantValue vs -> "variants"<+>block vs
-            CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
-            _ -> ppA lv
-
-instance PPA LinValue where
-  ppA lv = case lv of
-             LiteralValue l -> ppA l
-             ParamConstant pv -> ppA pv
-             PredefValue p -> ppA p
-             RecordValue [] -> pp "<>"
-             RecordValue rvs -> block rvs
-             PreValue alts def ->
-               "pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
-               where
-                 alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
-                                    2 ("=>"<+>lv)
-             TableValue _ tvs -> "table"<+>block tvs
---           VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts)
-             TupleValue lvs -> "<"<>punctuate "," lvs<>">"
-             VarValue v -> pp v
-             _ -> parens lv
-
-instance Pretty LinLiteral where pp = ppA
-
-instance PPA LinLiteral where
-  ppA l = case l of
-            FloatConstant f -> pp f
-            IntConstant n -> pp n
-            StrConstant s -> doubleQuotes s -- hmm
-
-instance RhsSeparator LinValue where rhsSep _ = pp "="
-
-instance Pretty LinPattern where
-  pp p =
-    case p of
-      ParamPattern pv -> pp pv
-      _ -> ppA p
-
-instance PPA LinPattern where
-  ppA p =
-    case p of
-      ParamPattern pv -> ppA pv
-      RecordPattern r -> block r
-      TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"
-
-instance RhsSeparator LinPattern where rhsSep _ = pp "="
-
-instance RhsSeparator rhs => Pretty (RecordRow rhs) where
-  pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
-
-instance Pretty rhs => Pretty (TableRow rhs) where
-  pp (TableRow l v) = hang (l<+>"=>") 2 v
-
---------------------------------------------------------------------------------
-instance Pretty ModId where pp (ModId s) = pp s
-instance Pretty CatId where pp (CatId s) = pp s
-instance Pretty FunId where pp (FunId s) = pp s
-instance Pretty LabelId where pp (LabelId s) = pp s
-instance Pretty PredefId where pp = ppA
-instance PPA    PredefId where ppA (PredefId s) = "Predef."<>s
-instance Pretty ParamId where pp = ppA
-instance PPA    ParamId where ppA (ParamId s) = pp s
-instance Pretty VarValueId where pp (VarValueId s) = pp s
-
-instance Pretty QualId where pp = ppA
-
-instance PPA QualId where
-  ppA (Qual m n) = m<>"_"<>n -- hmm
-  ppA (Unqual n) = pp n
-
-instance Pretty Flags where
-  pp (Flags []) = empty
-  pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)
-    where
-      ppFlag (name,value) = name <+> "=" <+> value <>";"
-
-instance Pretty FlagValue where
-  pp (Str s) = pp s
-  pp (Int i) = pp i
-  pp (Flt d) = pp d
-
---------------------------------------------------------------------------------
--- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
-class Pretty a => PPA a where ppA :: a -> Doc
-
-class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
-
-semiSep xs = punctuate ";" xs
-block xs = braces (semiSep xs)

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -1,298 +0,0 @@
-module GF.Grammar.CanonicalJSON (
-  encodeJSON
-  ) where
-
-import Text.JSON
-import Control.Applicative ((<|>))
-import Data.Ratio (denominator, numerator)
-import GF.Grammar.Canonical
-import Control.Monad (guard)
-import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
-
-
-encodeJSON :: FilePath -> Grammar -> IO ()
-encodeJSON fpath g = writeFile fpath (encode g)
-
-
--- in general we encode grammars using JSON objects/records,
--- except for newtypes/coercions/direct values
-
--- the top-level definitions use normal record labels,
--- but recursive types/values/ids use labels staring with a "."
-
-instance JSON Grammar where
-  showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
-
-  readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
-
-
---------------------------------------------------------------------------------
--- ** Abstract Syntax
-
-instance JSON Abstract where
-  showJSON (Abstract absid flags cats funs)
-    = makeObj [("abs", showJSON absid),
-               ("flags", showJSON flags),
-               ("cats", showJSON cats),
-               ("funs", showJSON funs)]
-
-  readJSON o = Abstract
-    <$> o!"abs"
-    <*>(o!"flags" <|> return (Flags []))
-    <*> o!"cats"
-    <*> o!"funs"
-
-instance JSON CatDef where
-  -- non-dependent categories are encoded as simple strings:
-  showJSON (CatDef c []) = showJSON c
-  showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
-
-  readJSON o = CatDef <$> readJSON o <*> return []
-    <|>        CatDef <$> o!"cat" <*> o!"args"
-
-instance JSON FunDef where
-  showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
-
-  readJSON o = FunDef <$> o!"fun" <*> o!"type"
-
-instance JSON Type where
-  showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
-
-  readJSON o = Type <$> o!".args" <*> o!".result"
-
-instance JSON TypeApp where
-  -- non-dependent categories are encoded as simple strings:
-  showJSON (TypeApp c [])   = showJSON c
-  showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
-
-  readJSON o = TypeApp <$> readJSON o <*> return []
-    <|>        TypeApp <$> o!".cat" <*> o!".args"
-
-instance JSON TypeBinding where
-  -- non-dependent categories are encoded as simple strings:
-  showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
-  showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
-
-  readJSON o = do c <- readJSON o
-                  return (TypeBinding Anonymous (Type [] (TypeApp c [])))
-           <|> TypeBinding <$> o!".var" <*> o!".type"
-
-
---------------------------------------------------------------------------------
--- ** Concrete syntax
-
-instance JSON Concrete where
-  showJSON (Concrete cncid absid flags params lincats lins)
-    = makeObj [("cnc", showJSON cncid),
-               ("abs", showJSON absid),
-               ("flags", showJSON flags),
-               ("params", showJSON params),
-               ("lincats", showJSON lincats),
-               ("lins", showJSON lins)]
-
-  readJSON o = Concrete
-    <$> o!"cnc"
-    <*> o!"abs"
-    <*>(o!"flags" <|> return (Flags []))
-    <*> o!"params"
-    <*> o!"lincats"
-    <*> o!"lins"
-
-instance JSON ParamDef where
-  showJSON (ParamDef      p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
-  showJSON (ParamAliasDef p t)   = makeObj [("param", showJSON p), ("alias", showJSON t)]
-
-  readJSON o = ParamDef      <$> o!"param" <*> o!"values"
-    <|>        ParamAliasDef <$> o!"param" <*> o!"alias"
-
-instance JSON LincatDef where
-  showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
-
-  readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
-
-instance JSON LinDef where
-  showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
-
-  readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
-
-instance JSON LinType where
-  -- the basic types (Str, Float, Int) are encoded as strings:
-  showJSON (StrType)         = showJSON "Str"
-  showJSON (FloatType)       = showJSON "Float"
-  showJSON (IntType)         = showJSON "Int"
-  -- parameters are also encoded as strings:
-  showJSON (ParamType pt)    = showJSON pt
-  -- tables/tuples are encoded as JSON objects:
-  showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
-  showJSON (TupleType lts)   = makeObj [(".tuple",  showJSON lts)]
-  -- records are encoded as records:
-  showJSON (RecordType rows) = showJSON rows
-
-  readJSON o = StrType   <$ parseString "Str"   o
-    <|>        FloatType <$ parseString "Float" o
-    <|>        IntType   <$ parseString "Int"   o
-    <|>        ParamType <$> readJSON o
-    <|>        TableType  <$> o!".tblarg" <*> o!".tblval"
-    <|>        TupleType  <$> o!".tuple"
-    <|>        RecordType <$> readJSON o
-
-instance JSON LinValue where
-  showJSON (LiteralValue  l ) = showJSON l
-  -- most values are encoded as JSON objects:
-  showJSON (ParamConstant pv) = makeObj [(".param",    showJSON pv)]
-  showJSON (PredefValue   p ) = makeObj [(".predef",   showJSON p)]
-  showJSON (TableValue t tvs) = makeObj [(".tblarg",   showJSON t), (".tblrows", showJSON tvs)]
-  showJSON (TupleValue   lvs) = makeObj [(".tuple",    showJSON lvs)]
-  showJSON (VarValue      v ) = makeObj [(".var",      showJSON v)]
-  showJSON (ErrorValue    s ) = makeObj [(".error",    showJSON s)]
-  showJSON (Projection lv l ) = makeObj [(".project",  showJSON lv), (".label", showJSON l)]
-  showJSON (Selection  tv pv) = makeObj [(".select",   showJSON tv), (".key", showJSON pv)]
-  showJSON (VariantValue  vs) = makeObj [(".variants", showJSON vs)]
-  showJSON (PreValue pre def) = makeObj [(".pre",      showJSON pre),(".default", showJSON def)]
-  -- records are encoded directly as JSON records:
-  showJSON (RecordValue rows) = showJSON rows
-  -- concatenation is encoded as a JSON array:
-  showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
-    where flatten (ConcatValue v v') = flatten v . flatten v'
-          flatten  v                 = (v :)
-
-  readJSON o = LiteralValue  <$> readJSON o
-    <|>        ParamConstant <$> o!".param"
-    <|>        PredefValue   <$> o!".predef"
-    <|>        TableValue    <$> o!".tblarg"  <*> o!".tblrows"
-    <|>        TupleValue    <$> o!".tuple"
-    <|>        VarValue      <$> o!".var"
-    <|>        ErrorValue    <$> o!".error"
-    <|>        Projection    <$> o!".project" <*> o!".label"
-    <|>        Selection     <$> o!".select"  <*> o!".key"
-    <|>        VariantValue  <$> o!".variants"
-    <|>        PreValue      <$> o!".pre"     <*> o!".default"
-    <|>        RecordValue   <$> readJSON o
-    <|>        do vs <- readJSON o :: Result [LinValue]
-                  return (foldr1 ConcatValue vs)
-
-instance JSON LinLiteral where
-  -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
-  showJSON (StrConstant   s) = showJSON s
-  showJSON (FloatConstant f) = showJSON f
-  showJSON (IntConstant   n) = showJSON n
-
-  readJSON = readBasicJSON StrConstant IntConstant FloatConstant
-
-instance JSON LinPattern where
-  -- wildcards and patterns without arguments are encoded as strings:
-  showJSON (WildPattern) = showJSON "_"
-  showJSON (ParamPattern (Param p [])) = showJSON p
-  -- complex patterns are encoded as JSON objects:
-  showJSON (ParamPattern pv) = showJSON pv
-  -- and records as records:
-  showJSON (RecordPattern r) = showJSON r
-
-  readJSON o = do  p  <- parseString "_" o; return WildPattern
-    <|>        do  p  <- readJSON o; return (ParamPattern (Param p []))
-    <|>        ParamPattern  <$> readJSON o
-    <|>        RecordPattern <$> readJSON o
-
-instance JSON arg => JSON (Param arg) where
-  -- parameters without arguments are encoded as strings:
-  showJSON (Param p [])   = showJSON p
-  showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
-
-  readJSON o = Param <$> readJSON o <*> return []
-    <|>        Param <$> o!".paramid" <*> o!".args"
-
-instance JSON a => JSON (RecordRow a) where
-  -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
-  showJSON  row  = showJSONs [row]
-  showJSONs rows = makeObj (map toRow rows)
-    where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
-
-  readJSON  obj = head <$> readJSONs obj
-  readJSONs obj = mapM fromRow (assocsJSObject obj)
-    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (RecordRow (LabelId (rawIdentS lbl)) value)
-
-instance JSON rhs => JSON (TableRow rhs) where
-  showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
-
-  readJSON o = TableRow <$> o!".pattern" <*> o!".value"
-
-
--- *** Identifiers in Concrete Syntax
-
-instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON
-instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON
-instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON
-instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON
-instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
-
-
---------------------------------------------------------------------------------
--- ** Used in both Abstract and Concrete Syntax
-
-instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
-instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
-instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
-
-instance JSON VarId where
-  -- the anonymous variable is the underscore:
-  showJSON Anonymous = showJSON "_"
-  showJSON (VarId x) = showJSON x
-
-  readJSON o = do parseString "_" o; return Anonymous
-    <|>        VarId <$> readJSON o
-
-instance JSON QualId where
-  showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
-  showJSON (Unqual n) = showJSON n
-
-  readJSON o = do qualid <- readJSON o
-                  let (mod, id) = span (/= '.') qualid
-                  return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
-
-instance JSON RawIdent where
-  showJSON i = showJSON $ showRawIdent i
-  readJSON o = rawIdentS <$> readJSON o
-
-instance JSON Flags where
-  -- flags are encoded directly as JSON records (i.e., objects):
-  showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
-
-  readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
-    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (rawIdentS lbl, value)
-
-instance JSON FlagValue where
-  -- flag values are encoded as basic JSON types:
-  showJSON (Str s) = showJSON s
-  showJSON (Int i) = showJSON i
-  showJSON (Flt f) = showJSON f
-
-  readJSON = readBasicJSON Str Int Flt
-
-
---------------------------------------------------------------------------------
--- ** Convenience functions
-
-parseString :: String -> JSValue -> Result ()
-parseString s o = guard . (== s) =<< readJSON o
-
-(!) :: JSON a => JSValue -> String -> Result a
-obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
-            readJSON
-            (lookup key (assocsJSObject obj))
-
-assocsJSObject :: JSValue -> [(String, JSValue)]
-assocsJSObject (JSObject o) = fromJSObject o
-assocsJSObject (JSArray  _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
-assocsJSObject  jsvalue     = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
-
-
-readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
-                 (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
-readBasicJSON str int flt o
-  =   str        <$> readJSON o
-  <|> int_or_flt <$> readJSON o
-  where int_or_flt f | f == fromIntegral n = int n
-                     | otherwise           = flt f
-          where n = round f

src/compiler/GF/Grammar/PatternMatch.hs

@@ -1,221 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : PatternMatch
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/12 12:38:29 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.7 $
---
--- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
------------------------------------------------------------------------------
-
-module GF.Grammar.PatternMatch (
-                                matchPattern,
-                                testOvershadow,
-                                findMatch,
-                                measurePatt
-                               ) where
-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Macros
---import GF.Grammar.Printer
-
---import Data.List
-import Control.Monad
-import GF.Text.Pretty
---import Debug.Trace
-
-matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
-matchPattern pts term =
-  if not (isInConstantForm term)
-    then raise (render ("variables occur in" <+> pp term))
-  else do
-    term' <- mkK term
-    errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
-      findMatch [([p],t) | (p,t) <- pts] [term']
- where
-  -- to capture all Str with string pattern matching
-  mkK s = case s of
-    C _ _ -> do
-      s' <- getS s
-      return (K (unwords s'))
-    _ -> return s
-
-  getS s = case s of
-    K w -> return [w]
-    C v w -> liftM2 (++) (getS v) (getS w)
-    Empty -> return []
-    _ -> raise (render ("cannot get string from" <+> s))
-
-testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
-testOvershadow pts vs = do
-  let numpts = zip pts [0..]
-  let cases  = [(p,EInt i) | (p,i) <- numpts]
-  ts <- mapM (liftM fst . matchPattern cases) vs
-  return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
-
-findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
-findMatch cases terms = case cases of
-   [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
-   (patts,_):_ | length patts /= length terms ->
-       raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
-                    "cannot take" <+> hsep terms))
-   (patts,val):cc -> case mapM tryMatch (zip patts terms) of
-       Ok substs -> return (val, concat substs)
-       _         -> findMatch cc terms
-
-tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do
-  t' <- termForm t
-  trym p t'
- where
-  trym p t' =
-    case (p,t') of
---    (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05
-      (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
-      (PW, _) -> return [] -- optimization with wildcard
-      (PV x,([],K s,[])) -> return [(x,words2term (words s))]
-      (PV x,  _) -> return [(x,t)]
-      (PString s, ([],K i,[])) | s==i -> return []
-      (PInt s, ([],EInt i,[])) | s==i -> return []
-      (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
-      (PC p pp, ([], Con f, tt)) |
-            p `eqStrIdent` f && length pp == length tt ->
-         do matches <- mapM tryMatch (zip pp tt)
-            return (concat matches)
-
-      (PP (q,p) pp, ([], QC (r,f), tt)) |
-            -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
-            p `eqStrIdent` f && length pp == length tt ->
-         do matches <- mapM tryMatch (zip pp tt)
-            return (concat matches)
-      ---- hack for AppPredef bug
-      (PP (q,p) pp, ([], Q (r,f), tt)) |
-            -- q `eqStrIdent` r && ---
-            p `eqStrIdent` f && length pp == length tt ->
-         do matches <- mapM tryMatch (zip pp tt)
-            return (concat matches)
-
-      (PR r, ([],R r',[])) |
-            all (`elem` map fst r') (map fst r) ->
-         do matches <- mapM tryMatch
-                            [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
-            return (concat matches)
-      (PT _ p',_) -> trym p' t'
-
-      (PAs x p',([],K s,[])) -> do
-         subst <- trym p' t'
-         return $ (x,words2term (words s)) : subst
-
-      (PAs x p',_) -> do
-         subst <- trym p' t'
-         return $ (x,t) : subst
-
-      (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
-
-      (PNeg p',_) -> case tryMatch (p',t) of
-        Bad _ -> return []
-        _ -> raise (render ("no match with negative pattern" <+> p))
-
-      (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
-      (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
-
-      (PRep p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq p1)) (PString "")
-           [1..n]) t' | n <- [0 .. length s]
-        ] >>
-        return []
-
-      (PChar,  ([],K [_], [])) -> return []
-      (PChars cs, ([],K [c], [])) | elem c cs -> return []
-
-      _ -> raise (render ("no match in case expr for" <+> t))
-
-  words2term []     = Empty
-  words2term [w]    = K w
-  words2term (w:ws) = C (K w) (words2term ws)
-
-
-matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
---matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
-matchPSeq p1 p2 s = matchPSeq' (lengthBounds p1) p1 (lengthBounds p2) p2 s
-
-matchPSeq' b1@(min1,max1) p1 b2@(min2,max2) p2 s =
-  do let n = length s
-         lo = min1 `max` (n-max2)
-         hi = (n-min2) `min` max1
-         cuts = [splitAt i s | i <- [lo..hi]]
-     matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
-     return (concat matches)
-
--- | Estimate the minimal length of the string that a pattern will match
-minLength = matchLength 0 id (+) min -- safe underestimate
-
--- | Estimate the maximal length of the string that a pattern will match
-maxLength =
-    maybe maxBound id . matchLength Nothing Just (liftM2 (+)) (liftM2 max)
-        -- safe overestimate
-
-matchLength unknown known seq alt = len
-  where
-    len p =
-      case p of
-        PString s  -> known (length s)
-        PSeq p1 p2 -> seq (len p1) (len p2)
-        PAlt p1 p2 -> alt (len p1) (len p2)
-        PChar      -> known 1
-        PChars _   -> known 1
-        PAs x p'   -> len p'
-        PT t p'    -> len p'
-        _          -> unknown
-
-lengthBounds p = (minLength p,maxLength p)
-
-mPatt p = (lengthBounds p,measurePatt p)
-
-measurePatt p =
-  case p of
-    PSeq p1 p2 -> PMSeq (mPatt p1) (mPatt p2)
-    _ -> composSafePattOp measurePatt p
-
-
-isInConstantForm :: Term -> Bool
-isInConstantForm trm = case trm of
-    Cn _     -> True
-    Con _    -> True
-    Q _      -> True
-    QC _     -> True
-    Abs _ _ _ -> True
-    C c a    -> isInConstantForm c && isInConstantForm a
-    App c a  -> isInConstantForm c && isInConstantForm a
-    R r      -> all (isInConstantForm . snd . snd) r
-    K _      -> True
-    Empty    -> True
-    EInt _   -> True
-    V ty ts  -> isInConstantForm ty && all isInConstantForm ts -- TH 2013-09-05
---  Typed e t-> isInConstantForm e && isInConstantForm t -- Add this? TH 2013-09-05
-
-    _       -> False ---- isInArgVarForm trm
-{- -- unused and suspicuous, see contP in GF.Compile.Compute.Concrete instead
-varsOfPatt :: Patt -> [Ident]
-varsOfPatt p = case p of
-  PV x -> [x]
-  PC _ ps -> concat $ map varsOfPatt ps
-  PP _ ps -> concat $ map varsOfPatt ps
-  PR r    -> concat $ map (varsOfPatt . snd) r
-  PT _ q -> varsOfPatt q
-  _ -> []
-
--- | to search matching parameter combinations in tables
-isMatchingForms :: [Patt] -> [Term] -> Bool
-isMatchingForms ps ts = all match (zip ps ts') where
-  match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
-  match _ = True
-  ts' = map appForm ts
-
--}

src/compiler/GF/Infra/BuildInfo.hs

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

src/compiler/GF/Infra/CompactPrint.hs

@@ -1,22 +0,0 @@
-module GF.Infra.CompactPrint where
-import Data.Char
-
-compactPrint = compactPrintCustom keywordGF (const False)
-
-compactPrintGFCC = compactPrintCustom (const False) keywordGFCC
-
-compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words 
-
-dps = dropWhile isSpace
-
-spaceIf pre post w = case w of
-  _ | pre w -> "\n" ++ w
-  _ | post w -> w ++ "\n"
-  c:_ | isAlpha c || isDigit c -> " " ++ w
-  '_':_  -> " " ++ w
-  _ -> w
-
-keywordGF w = elem w ["cat","fun","lin","lincat","lindef","oper","param"]
-keywordGFCC w = 
-  last w == ';' || 
-  elem w ["flags","fun","cat","lin","oper","lincat","lindef","printname","param"]

src/compiler/GF/Interactive.hs

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

src/compiler/GF/Interactive2.hs

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

src/compiler/Setup.hs

@@ -0,0 +1,4 @@
+import Distribution.Simple(defaultMain)
+
+main :: IO ()
+main = defaultMain

src/compiler/api/Data/Binary/Builder.hs

@@ -114,7 +114,7 @@ instance Semigroup Builder where
 instance Monoid Builder where
     mempty  = empty
     {-# INLINE mempty #-}
-    mappend = (<>)
+    mappend = append
     {-# INLINE mappend #-}
 
 ------------------------------------------------------------------------

src/compiler/api/Data/Binary/Get.hs

@@ -127,11 +127,11 @@ instance Functor Get where
     {-# INLINE fmap #-}
 
 instance Applicative Get where
-    pure a = Get (\s -> (a, s))
+    pure  = return
     (<*>) = ap
 
 instance Monad Get where
-    return = pure
+    return a  = Get (\s -> (a, s))
     {-# INLINE return #-}
 
     m >>= k   = Get (\s -> case unGet m s of

src/compiler/api/Data/Binary/Put.hs

@@ -77,20 +77,15 @@ instance Functor PutM where
         {-# INLINE fmap #-}
 
 instance Applicative PutM where
-        pure a  = Put $ PairS a mempty
+        pure    = return
         m <*> k = Put $
             let PairS f w  = unPut m
                 PairS x w' = unPut k
             in PairS (f x) (w `mappend` w')
-        m *> k  = Put $
-            let PairS _ w  = unPut m
-                PairS b w' = unPut k
-            in PairS b (w `mappend` w')
-        {-# INLINE (*>) #-}
 
 -- Standard Writer monad, with aggressive inlining
 instance Monad PutM where
-    return = pure
+    return a = Put $ PairS a mempty
     {-# INLINE return #-}
 
     m >>= k  = Put $
@@ -99,7 +94,10 @@ instance Monad PutM where
         in PairS b (w `mappend` w')
     {-# INLINE (>>=) #-}
 
-    (>>) = (*>)
+    m >> k  = Put $
+        let PairS _ w  = unPut m
+            PairS b w' = unPut k
+        in PairS b (w `mappend` w')
     {-# INLINE (>>) #-}
 
 tell :: Builder -> Put

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

@@ -1,6 +1,6 @@
-module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Term) where
+module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Literal(..),Term) where
 
-import PGF(CId,mkCId,Expr,showExpr)
+import PGF2
 import GF.Grammar.Grammar(Term)
 
 type Ident = String
@@ -11,17 +11,24 @@ type Pipe = [Command]
 
 data Command
    = Command Ident [Option] Argument
-   deriving (Eq,Ord,Show)
+   deriving Show
+
+data TransactionCommand
+   = CreateFun [Option] Fun Type
+   | CreateCat [Option] Cat [Hypo]
+   | CreateConcrete [Option] ConcName
+   | CreateLin [Option] Fun (Maybe Term) Bool
+   | CreateLincat [Option] Cat (Maybe Term)
+   | DropFun [Option] Fun
+   | DropCat [Option] Cat
+   | DropConcrete [Option] ConcName
+   | DropLin [Option] Fun
+   | DropLincat [Option] Cat
+   deriving Show
 
 data Option
   = OOpt Ident
-  | OFlag Ident Value
-  deriving (Eq,Ord,Show)
-
-data Value
-  = VId  Ident
-  | VInt Int
-  | VStr String
+  | OFlag Ident Literal
   deriving (Eq,Ord,Show)
 
 data Argument
@@ -29,19 +36,23 @@ data Argument
   | ATerm Term
   | ANoArg
   | AMacro Ident
-  deriving (Eq,Ord,Show)
-
-valCIdOpts :: String -> CId -> [Option] -> CId
-valCIdOpts flag def opts =
-  case [v | OFlag f (VId v) <- opts, f == flag] of
-    (v:_) -> mkCId v
-    _     -> def
+  deriving Show
 
 valIntOpts :: String -> Int -> [Option] -> Int
 valIntOpts flag def opts =
-  case [v | OFlag f (VInt v) <- opts, f == flag] of
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fromIntegral v
+    _     -> def
+
+valFltOpts :: String -> Double -> [Option] -> Double
+valFltOpts flag def opts =
+  case [v | OFlag f v <- opts, v <- toFlt v, f == flag] of
     (v:_) -> v
     _     -> def
+  where
+    toFlt (LInt v) = [fromIntegral v]
+    toFlt (LFlt f) = [f]
+    toFlt _        = []
 
 valStrOpts :: String -> String -> [Option] -> String
 valStrOpts flag def opts =
@@ -49,13 +60,25 @@ valStrOpts flag def opts =
     v:_ -> valueString v
     _   -> def
 
+maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
+maybeIntOpts flag def fn opts =
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fn (fromIntegral v)
+    _     -> def
+
+maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
+maybeStrOpts flag def fn opts =
+  case listFlags flag opts of
+    v:_ -> fn (valueString v)
+    _   -> def
+
 listFlags flag opts = [v | OFlag f v <- opts, f == flag]
 
 valueString v =
   case v of
-    VStr v -> v
-    VId  v -> v
-    VInt v -> show v
+    LInt v -> show v
+    LFlt v -> show v
+    LStr v -> v
 
 isOpt :: String -> [Option] -> Bool
 isOpt o opts = elem (OOpt o) opts

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

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

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

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

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

@@ -0,0 +1,95 @@
+module GF.Command.Importing (importGrammar, importSource) where
+
+import PGF2
+import PGF2.Transactions
+
+import GF.Compile
+import GF.Compile.Multi (readMulti)
+import GF.Compile.GetGrammar (getBNFCRules, getEBNFRules)
+import GF.Grammar (ModuleName,SourceGrammar) -- for cc command
+import GF.Grammar.BNFC
+import GF.Grammar.EBNF
+import GF.Grammar.CFG
+import GF.Compile.CFGtoPGF
+import GF.Infra.UseIO(die,tryIOE)
+import GF.Infra.Option
+import GF.Data.ErrM
+
+import System.FilePath
+import System.Directory
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad(foldM)
+import Control.Exception(catch,throwIO)
+
+-- import a grammar in an environment where it extends an existing grammar
+importGrammar :: (FilePath -> IO PGF) -> Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
+importGrammar readNGF pgf0 opts  _
+  | Just name <- flag optBlank opts = do
+        mb_ngf_file <- if snd (flag optLinkTargets opts)
+                         then do let fname = name <.> ".ngf"
+                                 putStr ("(Boot image "++fname++") ")
+                                 return (Just fname)
+                         else do return Nothing
+        pgf <- newNGF name mb_ngf_file 0
+        return (Just pgf)
+importGrammar readNGF pgf0 _    [] = return pgf0
+importGrammar readNGF pgf0 opts fs
+  | all (extensionIs ".cf")   fs = fmap Just $ importCF opts fs getBNFCRules bnfc2cf
+  | all (extensionIs ".ebnf") fs = fmap Just $ importCF opts fs getEBNFRules ebnf2cf
+  | all (extensionIs ".gfm")  fs = do
+        ascss <- mapM readMulti fs
+        let cs = concatMap snd ascss
+        importGrammar readNGF pgf0 opts cs
+  | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs = do
+        res <- tryIOE $ compileToPGF opts pgf0 fs
+        case res of
+          Ok pgf  -> return (Just pgf)
+          Bad msg -> do putStrLn ('\n':'\n':msg)
+                        return pgf0
+  | all (extensionIs ".pgf") fs = foldM (importPGF opts) pgf0 fs
+  | all (extensionIs ".ngf") fs = do
+        case fs of
+          [f] -> fmap Just $ readNGF f
+          _   -> die $ "Only one .ngf file could be loaded at a time"
+  | otherwise =  die $ "Don't know what to do with these input files: " ++ unwords fs
+  where
+    extensionIs ext = (== ext) .  takeExtension
+
+importPGF :: Options -> Maybe PGF -> FilePath -> IO (Maybe PGF)
+importPGF opts Nothing    f
+  | snd (flag optLinkTargets opts) = do let f' = replaceExtension f ".ngf"
+                                        exists <- doesFileExist f'
+                                        if exists
+                                          then removeFile f'
+                                          else return ()
+                                        putStr ("(Boot image "++f'++") ")
+                                        mb_probs <- case flag optProbsFile opts of
+                                                      Nothing   -> return Nothing
+                                                      Just file -> fmap Just (readProbabilitiesFromFile file)
+                                        fmap Just (bootNGFWithProbs f mb_probs f')
+  | otherwise                      = do mb_probs <- case flag optProbsFile opts of
+                                                      Nothing   -> return Nothing
+                                                      Just file -> fmap Just (readProbabilitiesFromFile file)
+                                        fmap Just (readPGFWithProbs f mb_probs)
+importPGF opts (Just pgf) f        = fmap Just (modifyPGF pgf (mergePGF f) `catch`
+                                                (\e@(PGFError loc msg) ->
+                                                      if msg == "The abstract syntax names doesn't match"
+                                                        then do putStrLn (msg++", previous concretes discarded.")
+                                                                readPGF f
+                                                        else throwIO e))
+
+importSource :: Options -> Maybe PGF -> [FilePath] -> IO (ModuleName,SourceGrammar)
+importSource opts mb_pgf files = batchCompile opts mb_pgf files
+
+-- for different cf formats
+importCF opts files get convert = impCF
+  where
+    impCF = do
+      rules <- fmap (convert . concat) $ mapM (get opts) files
+      startCat <- case rules of
+                    (Rule cat _ _ : _) -> return cat
+                    _                  -> fail "empty CFG"
+      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
+      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
+      return pgf

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

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

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

@@ -0,0 +1,154 @@
+module GF.Command.Parse(readCommandLine, readTransactionCommand, pCommand) where
+
+import PGF(pExpr,pIdent)
+import PGF2(BindType(..),readType,readContext)
+import GF.Infra.Ident(identS)
+import GF.Grammar.Grammar(Term(Abs))
+import GF.Grammar.Parser(runPartial,pTerm)
+import GF.Command.Abstract
+
+import Data.Char(isDigit,isSpace)
+import Control.Monad(liftM2)
+import Text.ParserCombinators.ReadP
+
+readCommandLine :: String -> Maybe CommandLine
+readCommandLine s =
+    case [x | (x,cs) <- readP_to_S pCommandLine s, all isSpace cs] of
+      [x] -> Just x
+      _   -> Nothing
+
+pCommandLine =
+  (skipSpaces >> char '-' >> char '-' >> pTheRest >> return [])   -- comment
+  <++
+  (sepBy (skipSpaces >> pPipe) (skipSpaces >> char ';'))
+
+pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
+
+pCommand = (do
+  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
+  skipSpaces
+  opts <- sepBy pOption skipSpaces
+  arg  <- if getCommandOp cmd `elem` ["cc","sd","so"] then pArgTerm else pArgument
+  return (Command cmd opts arg)
+  )
+    <++ (do
+  char '?'
+  skipSpaces
+  c <- pSystemCommand
+  return (Command "sp" [OFlag "command" (LStr c)] ANoArg)
+  )
+
+readTransactionCommand :: String -> Maybe TransactionCommand
+readTransactionCommand s =
+    case [x | (x,cs) <- readP_to_S pTransactionCommand s, all isSpace cs] of
+      [x] -> Just x
+      _   -> Nothing
+
+pTransactionCommand = do
+  skipSpaces
+  cmd <- pIdent
+  skipSpaces
+  opts <- sepBy pOption skipSpaces
+  skipSpaces
+  kwd <- pIdent
+  skipSpaces
+  case kwd of
+    "fun" | take 1 cmd == "c" -> do
+               f <- pIdent
+               skipSpaces
+               char ':'
+               skipSpaces
+               ty <- readS_to_P (\s -> case readType s of
+                                         Just ty -> [(ty,"")]
+                                         Nothing -> [])
+               return (CreateFun opts f ty)
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropFun opts f)
+    "cat" | take 1 cmd == "c" -> do
+               c <- pIdent
+               skipSpaces
+               ctxt <- readS_to_P (\s -> case readContext s of
+                                           Just ty -> [(ty,"")]
+                                           Nothing -> [])
+               return (CreateCat opts c ctxt)
+          | take 1 cmd == "d" -> do
+                c <- pIdent
+                return (DropCat opts c)
+    "concrete"
+          | take 1 cmd == "c" -> do
+               name <- pIdent
+               return (CreateConcrete opts name)
+          | take 1 cmd == "d" -> do
+               name <- pIdent
+               return (DropConcrete opts name)
+    "lin" | elem (take 1 cmd) ["c","a"] -> do
+               f <- pIdent
+               body <- option Nothing $ do
+                         skipSpaces
+                         args <- sepBy pIdent skipSpaces
+                         skipSpaces
+                         char '='
+                         skipSpaces
+                         t  <- readS_to_P (\s -> case runPartial pTerm s of
+                                                   Right (s,t) -> [(t,s)]
+                                                   _ -> [])
+                         return (Just (foldr (Abs Explicit . identS) t args))
+               return (CreateLin opts f body (take 1 cmd == "a"))
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropLin opts f)
+    "lincat"
+          | take 1 cmd == "c" -> do
+               f <- pIdent
+               body <- option Nothing $ do
+                         skipSpaces
+                         char '='
+                         skipSpaces
+                         t  <- readS_to_P (\s -> case runPartial pTerm s of
+                                                   Right (s,t) -> [(t,s)]
+                                                   _ -> [])
+                         return (Just t)
+               return (CreateLincat opts f body)
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropLincat opts f)
+    _     -> pfail
+
+pOption = do
+  char '-'
+  flg <- pIdent
+  option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
+
+pValue = do
+  fmap LInt (readS_to_P reads)
+  <++
+  fmap LFlt (readS_to_P reads)
+  <++
+  fmap LStr (readS_to_P reads)
+  <++
+  fmap LStr pFilename
+
+pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
+  isFileFirst c = not (isSpace c) && not (isDigit c)
+
+pArgument =
+  option ANoArg
+    (fmap AExpr pExpr
+              <++
+    (skipSpaces >> char '%' >> fmap AMacro pIdent))
+
+pArgTerm = ATerm `fmap` readS_to_P sTerm
+  where
+    sTerm s = case runPartial pTerm s of
+                Right (s,t) -> [(t,s)]
+                _ -> []
+
+pSystemCommand =
+    (char '"' >> (manyTill (pEsc <++ get) (char '"')))
+      <++
+    pTheRest
+  where
+    pEsc = char '\\' >> get
+
+pTheRest = munch (const True)

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

@@ -1,5 +1,6 @@
 -- | Commands requiring source grammar in env
 module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
+
 import Prelude hiding (putStrLn)
 import qualified Prelude as P(putStrLn)
 import Data.List(nub,isInfixOf,isPrefixOf)
@@ -7,21 +8,19 @@ import qualified Data.ByteString.UTF8 as UTF8(fromString)
 import qualified Data.Map as Map
 
 import GF.Infra.SIO(MonadSIO(..),restricted)
-import GF.Infra.Option(modifyFlags,optTrace) --,noOptions
-import GF.Data.Operations (chunks,err,raise)
-import GF.Text.Pretty(render)
+import GF.Infra.Dependencies(depGraph)
+import GF.Infra.CheckM
+import GF.Text.Pretty(render,pp)
 import GF.Data.Str(sstr)
+import GF.Data.Operations (chunks,err,raise)
 
 import GF.Grammar hiding (Ident,isPrefixOf)
 import GF.Grammar.Analyse
-import GF.Grammar.Parser (runP, pExp)
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
-import GF.Compile.Compute.Concrete(normalForm,resourceValues)
-import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
-import GF.Infra.Dependencies(depGraph)
-import GF.Infra.CheckM(runCheck)
+import GF.Compile.Compute.Concrete2(normalForm,normalFlatForm,Globals(..),stdPredef)
+import GF.Compile.TypeCheck.Concrete as TC(inferLType)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
 import GF.Command.CommandInfo
@@ -38,8 +37,8 @@ sourceCommands = Map.fromList [
      explanation = unlines [
        "Compute TERM by concrete syntax definitions. Uses the topmost",
        "module (the last one imported) to resolve constant names.",
-       "N.B.1 You need the flag -retain when importing the grammar, if you want",
-       "the definitions to be retained after compilation.",
+       "N.B.1 You need the flag -retain or -resource when importing the grammar,",
+       "if you want the definitions to be available after compilation.",
        "N.B.2 The resulting term is not a tree in the sense of abstract syntax",
        "and hence not a valid input to a Tree-expecting command.",
        "This command must be a line of its own, and thus cannot be a part",
@@ -51,10 +50,10 @@ sourceCommands = Map.fromList [
        ("one","pick the first strings, if there is any, from records and tables"),
        ("table","show all strings labelled by parameters"),
        ("unqual","hide qualifying module names"),
-       ("trace","trace computations")
+       ("flat","expand all variants and show a flat list of terms")
        ],
      needsTypeCheck = False, -- why not True?
-     exec = withStrings compute_concrete
+     exec = withTerm compute_concrete
      }),
   ("dg",  emptyCommandInfo {
      longname = "dependency_graph",
@@ -101,7 +100,7 @@ sourceCommands = Map.fromList [
        mkEx "sd -size ParadigmsEng.mkV    -- show all constants on which mkV depends, together with size"
        ],
      needsTypeCheck = False,
-     exec = withStrings show_deps
+     exec = withTerm show_deps
      }),
 
   ("so", emptyCommandInfo {
@@ -110,8 +109,9 @@ sourceCommands = Map.fromList [
      synopsis = "show all operations in scope, possibly restricted to a value type",
      explanation = unlines [
        "Show the names and type signatures of all operations available in the current resource.",
-       "This command requires a source grammar to be in scope, imported with 'import -retain'.",
-       "The operations include the parameter constructors that are in scope.",
+       "If no grammar is loaded with 'import -retain' or 'import -resource',",
+       "then only the predefined operations are in scope.",
+       "The operations include also the parameter constructors that are in scope.",
        "The optional TYPE filters according to the value type.",
        "The grep STRINGs filter according to other substrings of the type signatures."{-,
        "This command must be a line of its own, and thus cannot be a part",
@@ -129,7 +129,7 @@ sourceCommands = Map.fromList [
          mkEx "so | wf -file=/tmp/opers -- write the list of opers to a file"
        ],
      needsTypeCheck = False,
-     exec = withStrings show_operations
+     exec = withTerm show_operations
      }),
 
   ("ss", emptyCommandInfo {
@@ -162,15 +162,15 @@ sourceCommands = Map.fromList [
       do sgr <- getGrammar
          liftSIO (exec opts (toStrings ts) sgr)
 
-    compute_concrete opts ws sgr =
-      case runP pExp (UTF8.fromString s) of
-        Left (_,msg) -> return $ pipeMessage msg
-        Right t      -> return $ err pipeMessage
-                                     (fromString . showTerm sgr style q)
-                                 $ checkComputeTerm opts sgr t
+    withTerm exec opts ts =
+      do sgr <- getGrammar
+         liftSIO (exec opts (toTerm ts) sgr)
+
+    compute_concrete opts t sgr = fmap fst $ runCheck $ do
+      ts <- checkComputeTerm opts sgr t
+      return (fromStrings (map (showTerm sgr style q) ts))
       where
         (style,q) = pOpts TermPrintDefault Qualified opts
-        s = unwords ws
 
         pOpts style q []     = (style,q)
         pOpts style q (o:os) =
@@ -184,12 +184,8 @@ sourceCommands = Map.fromList [
             OOpt "qual"    -> pOpts style            Qualified   os
             _              -> pOpts style            q           os
 
-    show_deps os xs sgr = do
-          ops <- case xs of
-             _:_ -> do
-               let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
-               err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts
-             _   -> error "expected one or more qualified constants as argument"
+    show_deps os t sgr = do
+          ops <- err error (return . nub) $ constantDepsTerm sgr t
           let prTerm = showTerm sgr TermPrintDefault Qualified
           let size = sizeConstant sgr
           let printed
@@ -200,24 +196,15 @@ sourceCommands = Map.fromList [
                 | otherwise = unwords $ map prTerm ops
           return $ fromString printed
 
-    show_operations os ts sgr =
-      case greatestResource sgr of
-        Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?"
-        Just mo -> do
-          let greps = map valueString (listFlags "grep" os)
-          let isRaw = isOpt "raw" os
-          ops <- case ts of
-             _:_ -> do
-               let Right t = runP pExp (UTF8.fromString (unwords ts))
-               ty <- err error return $ checkComputeTerm os sgr t
-               return $ allOpersTo sgr ty
-             _   -> return $ allOpers sgr
-          let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
-          let printer = if isRaw
-                          then showTerm sgr TermPrintDefault Qualified
-                          else (render . TC.ppType)
-          let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
-          return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
+    show_operations os t sgr = fmap fst $ runCheck $ do
+      let greps = map valueString (listFlags "grep" os)
+      ops <- do tys <- checkComputeTerm os sgr t
+                return $ concatMap (allOpersTo sgr) tys
+      let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
+          printer = showTerm sgr TermPrintDefault
+                             (if isOpt "raw" os then Qualified else Unqualified)
+          printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
+      return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
 
     show_source os ts sgr = do
       let strip = if isOpt "strip" os then stripSourceGrammar else id
@@ -254,16 +241,20 @@ sourceCommands = Map.fromList [
          return void
 
 checkComputeTerm os sgr t =
-  do mo <- maybe (raise "no source grammar in scope") return $
-           greatestResource sgr
-     ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
-                                inferLType sgr [] t
-     let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-         t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
-         t2 = evalStr t1
-     checkPredefError t2
+  do mo <- case greatestResource sgr of
+             Nothing -> checkError (pp "No source grammar in scope")
+             Just mo -> return mo
+     t <- renameSourceTerm sgr mo t
+     (t,_) <- inferLType g t
+     if isOpt "flat" os
+       then fmap (map evalStr) (normalFlatForm g t)
+       else fmap (singleton . evalStr) (normalForm g t)
   where
     -- ** Try to compute pre{...} tokens in token sequences
+    singleton x = [x]
+
+    g = Gl sgr (stdPredef g)
+
     evalStr t =
       case t of
         C t1 t2 -> foldr1 C (evalC [t])

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

@@ -0,0 +1,39 @@
+module GF.Command.TreeOperations (
+  treeOp,
+  allTreeOps,
+  ) where
+
+import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unMeta,exprSize,exprFunctions)
+import Data.List
+
+type TreeOp = [Expr] -> [Expr]
+
+treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
+treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
+
+allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
+allTreeOps pgf = [
+   ("compute",("compute by using semantic definitions (def)",
+      Left  $ map (compute pgf))),
+   ("largest",("sort trees from largest to smallest, in number of nodes",
+      Left  $ largest)),
+   ("nub",("remove duplicate trees",
+      Left  $ nub)),
+   ("smallest",("sort trees from smallest to largest, in number of nodes",
+      Left  $ smallest)),
+   ("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest",
+      Left  $ concatMap subtrees)),
+   ("funs",("return all fun functions appearing in the tree, with duplications",
+      Left  $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e]))
+  ]
+
+largest :: [Expr] -> [Expr]
+largest = reverse . smallest
+
+smallest :: [Expr] -> [Expr]
+smallest = sortBy (\t u -> compare (exprSize t) (exprSize u))
+
+subtrees :: Expr -> [Expr]
+subtrees t = t : case unApp t of
+  Just (f,ts) -> concatMap subtrees ts
+  _ -> []  -- don't go under abstractions

src/compiler/api/GF/Compile.hs

@@ -1,46 +1,52 @@
 module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
 
-import GF.Compile.GrammarToPGF(mkCanon2pgf)
+import GF.Compile.GeneratePMCFG(generatePMCFG)
+import GF.Compile.GrammarToPGF(grammar2PGF)
 import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
                             importsOfModule)
 import GF.CompileOne(compileOne)
 
-import GF.Grammar.Grammar(Grammar,emptyGrammar,
-                          abstractOfConcrete,prependModule)--,msrc,modules
+import GF.Grammar.Grammar(Grammar,emptyGrammar,modules,mGrammar,
+                          abstractOfConcrete,prependModule,ModuleInfo(..))
 
+import GF.Infra.CheckM
 import GF.Infra.Ident(ModuleName,moduleNameS)--,showIdent
 import GF.Infra.Option
 import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
-                      justModuleName,extendPathEnv,putStrE,putPointE)
+                      justModuleName,extendPathEnv,putStrE,putPointE,warnOut)
 import GF.Data.Operations(raise,(+++),err)
 
-import Control.Monad(foldM,when,(<=<),filterM,liftM)
-import GF.System.Directory(doesFileExist,getModificationTime)
+import Control.Monad(foldM,when,(<=<))
+import GF.System.Directory(getCurrentDirectory,doesFileExist,getModificationTime)
 import System.FilePath((</>),isRelative,dropFileName)
-import qualified Data.Map as Map(empty,insert,elems) --lookup
+import qualified Data.Map as Map(empty,singleton,insert,elems)
 import Data.List(nub)
 import Data.Time(UTCTime)
 import GF.Text.Pretty(render,($$),(<+>),nest)
 
-import PGF.Internal(optimizePGF)
-import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
+import PGF2(PGF,abstractName,pgfFilePath,readProbabilitiesFromFile)
 
 -- | Compiles a number of source files and builds a 'PGF' structure for them.
 -- This is a composition of 'link' and 'batchCompile'.
-compileToPGF :: Options -> [FilePath] -> IOE PGF
-compileToPGF opts fs = link opts . snd =<< batchCompile opts fs
+compileToPGF :: Options -> Maybe PGF -> [FilePath] -> IOE PGF
+compileToPGF opts mb_pgf fs = link opts mb_pgf =<< batchCompile opts mb_pgf fs
 
 -- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
 -- 'PGF.parse' with the "PGF" run-time system.
-link :: Options -> (ModuleName,Grammar) -> IOE PGF
-link opts (cnc,gr) =
+link :: Options -> Maybe PGF -> (ModuleName,Grammar) -> IOE PGF
+link opts mb_pgf (cnc,gr) =
   putPointE Normal opts "linking ... " $ do
     let abs = srcAbsName gr cnc
-    pgf <- mkCanon2pgf opts gr abs
-    probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
+
+    -- if a module was compiled with no-pmcfg then we generate now
+    cwd <- getCurrentDirectory
+    (gr',warnings) <- runCheck' opts (fmap mGrammar $ mapM (generatePMCFG opts cwd gr) (modules gr))
+    warnOut opts warnings
+
+    probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
+    pgf <- grammar2PGF opts mb_pgf gr' abs probs
     when (verbAtLeast opts Normal) $ putStrE "OK"
-    return $ setProbabilities probs 
-           $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
+    return pgf
 
 -- | Returns the name of the abstract syntax corresponding to the named concrete syntax
 srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
@@ -50,42 +56,27 @@ srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
 -- used, in which case tags files are produced instead).
 -- Existing @.gfo@ files are reused if they are up-to-date
 -- (unless the option @-src@ aka @-force-recomp@ is used).
-batchCompile :: Options -> [FilePath] -> IOE (UTCTime,(ModuleName,Grammar))
-batchCompile opts files = do
-  (gr,menv) <- foldM (compileModule opts) emptyCompileEnv files
+batchCompile :: Options -> Maybe PGF -> [FilePath] -> IOE (ModuleName,Grammar)
+batchCompile opts mb_pgf files = do
+  menv <- emptyCompileEnv mb_pgf
+  (gr,menv) <- foldM (compileModule opts) menv files
   let cnc = moduleNameS (justModuleName (last files))
-      t = maximum . map fst $ Map.elems menv
-  return (t,(cnc,gr))
-{-
--- to compile a set of modules, e.g. an old GF or a .cf file
-compileSourceGrammar :: Options -> Grammar -> IOE Grammar
-compileSourceGrammar opts gr = do
-  cwd <- getCurrentDirectory
-  (_,gr',_) <- foldM (\env -> compileSourceModule opts cwd env Nothing)
-                     emptyCompileEnv
-                     (modules gr)
-  return gr'
--}
+  return (cnc,gr)
 
 -- | compile with one module as starting point
 -- command-line options override options (marked by --#) in the file
 -- As for path: if it is read from file, the file path is prepended to each name.
 -- If from command line, it is used as it is.
-
 compileModule :: Options -- ^ Options from program command line and shell command.
               -> CompileEnv -> FilePath -> IOE CompileEnv
 compileModule opts1 env@(_,rfs) file =
   do file <- getRealFile file
      opts0 <- getOptionsFromFile file
      let curr_dir = dropFileName file
-     lib_dirs <- getLibraryDirectory (addOptions opts0 opts1)
-     let opts = addOptions (fixRelativeLibPaths curr_dir lib_dirs opts0) opts1
---     putIfVerb opts $ "curr_dir:" +++ show curr_dir ----
---     putIfVerb opts $ "lib_dir:" +++ show lib_dirs ----
+     lib_dir  <- getLibraryDirectory (addOptions opts0 opts1)
+     let opts = addOptions (fixRelativeLibPaths curr_dir lib_dir opts0) opts1
      ps0 <- extendPathEnv opts
      let ps = nub (curr_dir : ps0)
---     putIfVerb opts $ "options from file: " ++ show opts0
---     putIfVerb opts $ "augmented options: " ++ show opts
      putIfVerb opts $ "module search path:" +++ show ps ----
      files <- getAllFiles opts ps rfs file
      putIfVerb opts $ "files to read:" +++ show files ----
@@ -98,17 +89,13 @@ compileModule opts1 env@(_,rfs) file =
       if exists
         then return file
         else if isRelative file
-               then do
-                       lib_dirs <- getLibraryDirectory opts1
-                       let candidates = [ lib_dir </> file | lib_dir <- lib_dirs ]
-                       putIfVerb opts1 (render ("looking for: " $$ nest 2 candidates))
-                       file1s <- filterM doesFileExist candidates
-                       case length file1s of
-                         0 -> raise (render ("Unable to find: " $$ nest 2 candidates))
-                         1 -> do return $ head file1s
-                         _ -> do putIfVerb opts1 ("matched multiple candidates: " +++ show file1s)
-                                 return $ head file1s
-               else raise (render ("File" <+> file <+> "does not exist"))
+               then do lib_dir <- getLibraryDirectory opts1
+                       let file1 = lib_dir </> file
+                       exists <- doesFileExist file1
+                       if exists
+                         then return file1
+                         else raise (render ("None of these files exists:" $$ nest 2 (file $$ file1)))
+               else raise (render ("File" <+> file <+> "does not exist."))
 
 compileOne' :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
 compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr
@@ -118,14 +105,25 @@ compileOne' opts env@(gr,_) = extendCompileEnv env <=< compileOne opts gr
 -- | The environment
 type CompileEnv = (Grammar,ModEnv)
 
-emptyCompileEnv :: CompileEnv
-emptyCompileEnv = (emptyGrammar,Map.empty)
+emptyCompileEnv :: Maybe PGF -> IOE CompileEnv
+emptyCompileEnv mb_pgf = do
+  case mb_pgf of
+    Just pgf -> do let abs_name = abstractName pgf
+                   env <- case pgfFilePath pgf of
+                            Just fpath -> do t <- getModificationTime fpath
+                                             return (Map.singleton abs_name (fpath,t,[]))
+                            Nothing    -> return Map.empty
+                   return ( prependModule emptyGrammar (moduleNameS abs_name, ModPGF pgf)
+                          , env
+                          )
+    Nothing  -> return (emptyGrammar,Map.empty)
+
 
 extendCompileEnv (gr,menv) (mfile,mo) =
   do menv2 <- case mfile of
                 Just file ->
                   do let (mod,imps) = importsOfModule mo
                      t <- getModificationTime file
-                     return $ Map.insert mod (t,imps) menv
+                     return $ Map.insert mod (file,t,imps) menv
                 _ -> return menv
      return (prependModule gr mo,menv2)

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

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

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

@@ -21,15 +21,14 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.CheckGrammar(checkModule) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
+import Prelude hiding ((<>))
 import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
-import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
-import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
+import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
+import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -54,11 +53,7 @@ checkModule opts cwd sgr mo@(m,mi) = do
                              checkCompleteGrammar opts cwd gr (a,abs) mo
           _            -> return mo
   infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
-  foldM updateCheckInfos mo infoss
-  where
-    updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
-      where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
-    update mo@(m,mi) (i,info) = (m,mi{jments=Map.insert i info (jments mi)})
+  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
@@ -69,7 +64,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
                              -- the restr. modules themself, with restr. infos
   mapM_ checkRem mrs
  where
-   mos = modules sgr
+   mos = [mo | mo@(_,ModInfo{}) <- modules sgr]
    checkRem ((i,m),mi) = do
      let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
      let incld c   = Set.member c (Set.fromList incl)
@@ -120,8 +115,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                                     return js
                    _ -> do
                      case mb_def of
-                       Ok def -> do (cont,val) <- linTypeOfType gr cm ty
-                                    let linty = (snd (valCat ty),cont,val)
+                       Ok def -> do linty <- linTypeOfType gr cm (L loc ty)
                                     return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
                        Bad _  -> do noLinOf c
                                     return js
@@ -140,9 +134,8 @@ 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 _ ty)) _ _ _) ->
-                                        do (cont,val) <- linTypeOfType gr cm ty
-                                           let linty = (snd (valCat ty),cont,val)
+                             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")
                                            return js
@@ -158,130 +151,125 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
 
        _ -> return $ Map.insert c info js
 
-
--- | General Principle: only Just-values are checked.
--- A May-value has always been checked in its origin module.
-checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
-checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
+checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> (Ident,Info) -> Check SourceModule
+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" $
         checkContext gr cont
 
-    AbsFun (Just (L loc typ0)) ma md moper -> do
-      typ <- compAbsTyp [] typ0   -- to calculate let definitions
+    AbsFun (Just (L loc typ)) ma md moper -> do
       mkCheck loc "the type of function" $
         checkTyp gr typ
+      typ <- compAbsTyp [] typ   -- to calculate let definitions
       case md of
         Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
-                                          checkDef gr (m,c) typ eq) eqs
+                                          checkDef gr (fst sm,c) typ eq) eqs
         Nothing  -> return ()
-      return (AbsFun (Just (L loc typ)) ma md moper)
+      update sm c (AbsFun (Just (L loc typ)) ma md moper)
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
-                Just (L loc typ) -> chIn loc "linearization type of" $
-                                     (if False --flag optNewComp opts
-                                        then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
-                                                typ  <- computeLType gr [] typ
-                                                return (Just (L loc typ))
-                                        else do (typ,_) <- checkLType gr [] typ typeType
-                                                typ  <- computeLType gr [] typ
-                                                return (Just (L loc typ)))
+                Just (L loc typ) -> chIn loc "linearization type of" $ do
+                                      (typ,_) <- checkLType g typ typeType
+                                      typ  <- normalForm g 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 gr [] def (mkFunType [typeStr] typ)
+                       (def,_) <- checkLType g 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 gr [] ref (mkFunType [typ] typeStr)
+                       (ref,_) <- checkLType g 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 gr [] t typeStr
+                       (t,_) <- checkLType g t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
-      return (CncCat mty mdef mref mpr mpmcfg)
+      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 (_,cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
-                     (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
-                     return (Just (L loc trm))
+                     (trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) 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 gr [] t typeStr
+                       (t,_) <- checkLType g t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
-      return (CncFun mty mt mpr mpmcfg)
+      update sm c (CncFun mty mt mpr mpmcfg)
 
     ResOper pty pde -> do
       (pty', pde') <- case (pty,pde) of
          (Just (L loct ty), Just (L locd de)) -> do
-           ty'     <- chIn loct "operation" $
-                         (if False --flag optNewComp opts
-                            then CN.checkLType (CN.resourceValues opts gr) ty typeType >>= return . CN.normalForm (CN.resourceValues opts gr) (L loct c) . fst -- !!
-                            else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
+           ty'     <- chIn loct "operation" $ do
+                         (ty,_) <- checkLType g ty typeType
+                         normalForm g ty
            (de',_) <- chIn locd "operation" $
-                         (if False -- flag optNewComp opts
-                            then CN.checkLType (CN.resourceValues opts gr) de ty'
-                            else checkLType gr [] de ty')
+                         checkLType g de ty'
            return (Just (L loct ty'), Just (L locd de'))
          (Nothing         , Just (L locd de)) -> do
            (de',ty') <- chIn locd "operation" $
-                          (if False -- flag optNewComp opts
-                            then CN.inferLType (CN.resourceValues opts gr) de
-                            else inferLType gr [] de)
+                          inferLType g 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")
-      return (ResOper pty' pde')
+      update sm c (ResOper pty' pde')
 
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
-      tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
-      tysts0 <- lookupOverload gr (m,c)  -- check against inherited ones too
-      tysts1 <- mapM (uncurry $ flip (checkLType gr []))
-                  [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
+      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
+      tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
+      tysts1 <- sequence
+                  [checkLType g 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]
-      return (ResOverload os [(y,x) | (x,y) <- tysts'])
+      --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'])
 
     ResParam (Just (L loc pcs)) _ -> do
-      ts <- chIn loc "parameter type" $
-              liftM concat $ mapM mkPar pcs
-      return (ResParam (Just (L loc pcs)) (Just ts))
+      (sm,cnt,ts,pcs) <- chIn loc "parameter type" $
+                            mkParamValues sm c 0 [] pcs
+      update sm c (ResParam (Just (L loc pcs)) (Just (ts,cnt)))
 
-    _ ->  return info
+    _ ->  return sm
  where
-   gr = prependModule sgr (m,mo)
-   chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
+   gr = prependModule sgr sm
+   g = Gl gr (stdPredef g)
+   chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
 
-   mkPar (f,co) = do
-       vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
-       return $ map (mkApp (QC (m,f))) vs
+   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
+     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)
+     vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+     (sm,cnt,ts,pcs) <- mkParamValues sm c (cnt+length vs) ts pcs
+     return (sm,cnt,map (mkApp (QC (mn,p))) vs ++ ts,(p,co):pcs)
 
    checkUniq xss = case xss of
      x:y:xs
       | x == y    -> checkError $ "ambiguous for type" <+>
-                                  ppType (mkFunType (tail x) (head x))
+                                  ppTerm Terse 0 (mkFunType (tail x) (head x))
       | otherwise -> checkUniq $ y:xs
      _ -> return ()
 
    mkCheck loc cat ss = case ss of
-     [] -> return info
+     [] -> return sm
      _ -> chIn loc cat $ checkError (vcat ss)
 
    compAbsTyp g t = case t of
@@ -296,35 +284,50 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
      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)
+     where
+       x = freeVar 1 xs
+
+       freeVar i xs
+         | elem x xs = freeVar (i+1) xs
+         | otherwise = x
+         where
+           x = identS ("v"++show i)
+
+   update (mn,mi) c info = return (mn,mi{jments=Map.insert c info (jments mi)})
+
 
 -- | for grammars obtained otherwise than by parsing ---- update!!
 checkReservedId :: Ident -> Check ()
 checkReservedId x =
-  when (isReservedWord x) $
+  when (isReservedWord GF x) $
        checkWarn ("reserved word used as identifier:" <+> x)
 
 -- auxiliaries
 
 -- | linearization types and defaults
-linTypeOfType :: Grammar -> ModuleName -> Type -> Check (Context,Type)
-linTypeOfType cnc m typ = do
-  let (cont,cat) = typeSkeleton typ
-  val  <- lookLin cat
-  args <- mapM mkLinArg (zip [0..] cont)
-  return (args, val)
+linTypeOfType :: Grammar -> ModuleName -> L Type -> Check ([Ident],Ident,Context,Type)
+linTypeOfType cnc m (L loc typ) = do
+  let (ctxt,res_cat) = typeSkeleton typ
+  val <- lookLin res_cat
+  lin_args <- mapM mkLinArg (zip [1..] ctxt)
+  let (args,arg_cats) = unzip lin_args
+  return (arg_cats, snd res_cat, args, val)
  where
    mkLinArg (i,(n,mc@(m,cat))) = do
      val  <- lookLin mc
      let vars = mkRecType varLabel $ replicate n typeStr
-         symb = argIdent n cat i
      rec <- if n==0 then return val else
                        errIn (render ("extending" $$
                                       nest 2 vars $$
                                       "with" $$
                                       nest 2 val)) $
                              plusRecType vars val
-     return (Explicit,symb,rec)
+     return ((Explicit,varX i,rec),cat)
    lookLin (_,c) = checks [ --- rather: update with defLinType ?
-      lookupLincat cnc m c >>= computeLType cnc []
+      lookupLincat cnc m c >>= normalForm g
      ,return defLinType
      ]
+   g = Gl cnc (stdPredef g)

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

@@ -0,0 +1,205 @@
+-- | Translate concrete syntax to Haskell
+module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
+
+import PGF2(Literal(..))
+import Data.List(isPrefixOf,sort,sortOn)
+import qualified Data.Map as Map
+import GF.Text.Pretty
+import GF.Grammar.Predef
+import GF.Grammar.Grammar
+import GF.Grammar.Macros
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Haskell as H
+import GF.Compile.GrammarToCanonical
+
+-- | Generate Haskell code for the all concrete syntaxes associated with
+-- the named abstract syntax in given the grammar.
+concretes2haskell opts absname gr = do
+  gr <- grammar2canonical opts absname gr
+  let abstr:concrs = modules gr
+  return [(filename,render80 $ concrete2haskell opts abstr concr)
+             | concr@(MN mn,_) <- concrs,
+               let filename = showIdent mn ++ ".hs" :: FilePath
+         ]
+
+-- | Generate Haskell code for the given concrete module.
+-- The only options that make a difference are
+-- @-haskell=noprefix@ and @-haskell=variants@.
+concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
+  haskPreamble absname cncname $$
+  vcat (
+    nl:Comment "--- Parameter types ---":
+    [paramDef id ps | (id,ResParam (Just (L _ ps)) _) <- Map.toList (jments mi)] ++
+    nl:Comment "--- Type signatures for linearization functions ---":
+    [signature id | (id,CncCat _ _ _ _ _) <- Map.toList (jments mi)] ++
+    nl:Comment "--- Linearization types ---":
+    [lincatDef id ty | (id,CncCat (Just (L _ ty)) _ _ _ _) <- Map.toList (jments mi)] ++
+    nl:Comment "--- Linearization functions ---":
+    concat (Map.elems lindefs) ++
+    nl:Comment "--- Type classes for projection functions ---":
+    -- map labelClass (S.toList labels) ++
+    nl:Comment "--- Record types ---":
+    [] -- concatMap recordType recs
+    )
+  where
+    nl = Comment ""
+
+    signature c = TypeSig lf (Fun abs (pure lin))
+      where
+        abs = tcon0 (prefixIdent "A." (gId c))
+        lin = tcon0 lc
+        lf = linfunName c
+        lc = lincatName c
+
+    gId :: Ident -> Ident
+    gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
+
+    va = haskellOption opts HaskellVariants
+    pure = if va then ListT else id
+
+    haskPreamble :: ModuleName -> ModuleName -> Doc
+    haskPreamble absname cncname =
+      "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
+      "module" <+> cncname <+> "where" $$
+      "import Prelude hiding (Ordering(..))" $$
+      "import Control.Applicative((<$>),(<*>))" $$
+      "import qualified" <+> absname <+> "as A" $$
+      "" $$
+      "-- | Token sequences, output form linearization functions" $$
+      "type Str = [Tok] -- token sequence" $$
+      "" $$
+      "-- | Tokens" $$
+      "data Tok = TK String | TP [([Prefix],Str)] Str | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT" $$
+      "         deriving (Eq,Ord,Show)" $$
+      "" $$
+      "--- Standard definitions ---" $$
+      "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
+      "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
+      "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
+      "" $$
+      "----------------------------------------------------" $$
+      "-- Automatic translation from GF to Haskell follows" $$
+      "----------------------------------------------------"
+      where
+        pure = if va then brackets else pp
+
+    paramDef id pvs = Data (conap0 (gId id)) (map paramCon pvs) derive
+      where
+        paramCon (id,ctxt) = ConAp (gId id) [tcon0 (gId cat) | (_,_,QC (_,cat)) <- ctxt]
+        derive = ["Eq","Ord","Show"]
+
+    convLinType (Sort s)
+      | 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
+    convLinType (Table pt lt) = Fun (convLinType pt) (convLinType lt)
+
+    lincatDef c ty = tsyn0 (lincatName c) (convLinType ty)
+
+    lindefs =
+      Map.fromListWith (++) 
+        [linDef id absctx cat lincat rhs |
+            (id,CncFun (Just (absctx,cat,_,lincat)) (Just (L _ rhs)) _ _) <- Map.toList (jments mi)]
+
+    linDef f absctx cat lincat rhs0 =
+      (cat,[Eqn (linfunName cat,lhs) rhs'])
+      where
+        lhs = [ConP (aId f) (map VarP abs_args)]
+        aId f = prefixIdent "A." (gId f)
+
+        --[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
+        (xs,rhs) = termFormCnc rhs0
+
+        abs_args = map abs_arg args
+        abs_arg = prefixIdent "abs_"
+        args = map (prefixIdent "g" . snd) xs
+
+        rhs' = lets (zipWith letlin args absctx)
+                    (convert rhs)
+          where
+            vs = [(x,a)|((_,x),a)<-zip xs args]
+
+        letlin a acat =
+          (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
+
+    convert (Vr v) = Var (gId v)
+    convert (EInt n) = lit n
+    convert (EFloat d) = lit d
+    convert (K s) = single (Const "TK" `Ap` lit s)
+    convert Empty = List []
+    convert (App t1 t2) = Ap (convert t1) (convert t2)
+    convert (R lbls) = aps (rcon ls) (map (convert.snd) ts)
+                         where (ls,ts) = unzip (sortOn fst lbls)
+    convert (P t lbl) = ap (proj lbl) (convert t)
+    convert (ExtR t1 t2) = Const "ExtR" -- TODO
+    convert (T _ cs) = LambdaCase (map ppCase cs)
+      where
+        ppCase (p,t) = (convertPatt p,convert t)
+    convert (V _ ts) = Const "V" -- TODO
+    convert (S t p)
+      | va        = select_va (convert t) (convert p)
+      | otherwise = Ap (convert t) (convert p)
+      where
+        select_va (List [t]) (List [p]) = Op t "!" p
+        select_va (List [t]) p = Op t "!$" p
+        select_va t p = Op t "!*" p
+    convert (Q  (_,id)) = single (Var id)
+    convert (QC (_,id)) = single (Var id)
+    convert (C t1 t2)
+      | va        = concat_va (convert t1) (convert t2)
+      | otherwise = plusplus  (convert t1) (convert t2)
+      where
+        concat_va (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
+        concat_va t1 t2 = Op t1 "+++" t2
+    convert (Glue t1 t2) = Const "Glue"
+    convert (FV ts)
+      | va        = join (List (map convert ts))
+      | otherwise = case ts of
+                      []     -> Const "error" `Ap` Const (show "empty variant")
+                      (t:ts) -> convert t
+      where
+        join (List [x]) = x
+        join x = Const "concat" `Ap` x
+    convert (Alts def alts) = single (Const "TP" `Ap` List (map convAlt alts) `Ap` convert def)
+      where
+        convAlt (t1,t2) = Pair (convert t1) (convert t2)
+    convert (Strs ss) = List (map lit ss)
+    convert t = error (show t)
+
+    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 PW            = WildP
+    convertPatt (PR lbls)     = ConP (rcon' ls) (map convertPatt ps)
+      where (ls,ps) = unzip $ sortOn fst lbls
+    convertPatt (PString s)   = Lit s
+    convertPatt (PT _ p)      = convertPatt p
+    convertPatt (PAs v p)     = AsP v (convertPatt p)
+    convertPatt (PImplArg p)  = convertPatt p
+    convertPatt (PTilde _)    = WildP
+    convertPatt (PAlt _ _)    = WildP -- TODO
+    convertPatt p = error (show p)
+
+    lit s = Const (show s) -- hmm
+
+    ap = if va then ap' else Ap
+       where
+         ap' (List [f]) x = fmap f x
+         ap' f x = Op f "<*>" x
+         fmap f (List [x]) = Ap f x
+         fmap f x = Op f "<$>" x
+
+    aps f [] = f
+    aps f (a:as) = aps (ap f a) as
+
+proj = Var . identS . proj'
+proj' (LIdent l) = "proj_" ++ showRawIdent l
+rcon = Var . rcon'
+rcon' = identS . rcon_name
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LIdent l <- ls])
+
+lincatName,linfunName :: Ident -> Ident
+lincatName c = prefixIdent "Lin" c
+linfunName c = prefixIdent "lin" c

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

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

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

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