added MonadFix and fix how return is defined

majestic: fix bubbling + type annotations for option metadata

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

@@ -18,7 +18,7 @@ jobs:
         ghc:
           - "8.6.5"
           - "8.8.3"
-          - "8.10.1"
+          - "8.10.7"
         exclude:
           - os: macos-latest
             ghc: 8.8.3
@@ -33,7 +33,7 @@ jobs:
     - uses: actions/checkout@v2
       if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
 
-    - uses: haskell/actions/setup@v1
+    - uses: haskell/actions/setup@v1.2.9
       id: setup-haskell-cabal
       name: Setup Haskell
       with:
@@ -66,25 +66,32 @@ jobs:
     strategy:
       matrix:
         stack: ["latest"]
-        ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4"]
+        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@v1
+    - uses: haskell/actions/setup@v1.2.9
       name: Setup Haskell Stack
       with:
         ghc-version: ${{ matrix.ghc }}
         stack-version: 'latest'
         enable-stack: true
 
+
+    # Fix linker errrors on ghc-7.10.3 for ubuntu (see https://github.com/commercialhaskell/stack/blob/255cd830627870cdef34b5e54d670ef07882523e/doc/faq.md#i-get-strange-ld-errors-about-recompiling-with--fpic)
+    - run: sed -i.bak 's/"C compiler link flags", "/&-no-pie /' /home/runner/.ghcup/ghc/7.10.3/lib/ghc-7.10.3/settings
+      if: matrix.ghc == '7.10.3'
+
     - uses: actions/cache@v1
       name: Cache ~/.stack
       with:
         path: ~/.stack
-        key: ${{ runner.os }}-${{ matrix.ghc }}-stack
+        key: ${{ runner.os }}-${{ matrix.ghc }}-stack--${{ hashFiles(format('stack-ghc{0}', matrix.ghc)) }}
+        restore-keys: |
+             ${{ runner.os }}-${{ matrix.ghc }}-stack
 
     - name: Build
       run: |

.github/workflows/build-majestic.yml

@@ -7,12 +7,14 @@ env:
 
 jobs:
 
-  ubuntu-runtime:
-    name: Runtime (Ubuntu)
-    runs-on: ubuntu-20.04
+  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@v2
+    - uses: actions/checkout@v3
 
     - name: Build runtime
       working-directory: ./src/runtime/c
@@ -20,91 +22,117 @@ jobs:
         autoreconf -i
         ./configure
         make
-        sudo make install
+        make install
 
     - name: Upload artifact
-      uses: actions/upload-artifact@master
+      uses: actions/upload-artifact@v3
       with:
-        name: libpgf-ubuntu
+        name: libpgf-linux
         path: |
           /usr/local/lib/libpgf*
           /usr/local/include/pgf
 
-  ubuntu-haskell:
-    name: Haskell (Ubuntu)
-    runs-on: ubuntu-20.04
-    needs: ubuntu-runtime
+  linux-haskell:
+    name: Haskell (Linux)
+    runs-on: ubuntu-latest
+    needs: linux-runtime
 
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v3
     - name: Download artifact
-      uses: actions/download-artifact@master
+      uses: actions/download-artifact@v3
       with:
-        name: libpgf-ubuntu
+        name: libpgf-linux
     - run: |
         sudo mv lib/* /usr/local/lib/
         sudo mv include/* /usr/local/include/
 
     - name: Setup Haskell
-      uses: haskell/actions/setup@v1
+      uses: haskell/actions/setup@v2
+      with:
+        ghc-version: 8
 
-    - name: Build & run testsuite
+    - name: Install Haskell build tools
+      run: |
+        cabal v1-install alex happy
+
+    - name: build and test the runtime
       working-directory: ./src/runtime/haskell
       run: |
+        cabal v1-install --extra-lib-dirs=/usr/local/lib
         cabal test --extra-lib-dirs=/usr/local/lib
 
-  ubuntu-python:
-    name: Python (Ubuntu)
-    runs-on: ubuntu-20.04
-    needs: ubuntu-runtime
+    - 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@v2
+    - uses: actions/checkout@v3
     - name: Download artifact
-      uses: actions/download-artifact@master
+      uses: actions/download-artifact@v3
       with:
-        name: libpgf-ubuntu
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
+        name: libpgf-linux
 
-    - name: Install bindings
-      working-directory: ./src/runtime/python
+    - name: Install cibuildwheel
       run: |
-        python setup.py build
-        sudo python setup.py install
+        python3 -m pip install git+https://github.com/joerick/cibuildwheel.git@main
 
-    - name: Run testsuite
-      working-directory: ./src/runtime/python
+    - 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: |
-        pip install pytest
-        pytest
+        python3 -m cibuildwheel src/runtime/python --output-dir wheelhouse
 
-  ubuntu-javascript:
-    name: JavaScript (Ubuntu)
-    runs-on: ubuntu-20.04
-    needs: ubuntu-runtime
-    if: false
-
-    steps:
-    - uses: actions/checkout@v2
-    - name: Download artifact
-      uses: actions/download-artifact@master
+    - uses: actions/upload-artifact@master
       with:
-        name: libpgf-ubuntu
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
+        name: python-linux
+        path: ./wheelhouse
 
-    - name: Install dependencies
-      working-directory: ./src/runtime/javascript
-      run: |
-        npm ci
-
-    - name: Run testsuite
-      working-directory: ./src/runtime/javascript
-      run: |
-        npm run test
+#  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
 
 # ----------------------------------------------------------------------------
 
@@ -113,7 +141,7 @@ jobs:
     runs-on: macOS-11
 
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v3
 
     - name: Install build tools
       run: |
@@ -145,7 +173,7 @@ jobs:
     needs: macos-runtime
 
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v3
     - name: Download artifact
       uses: actions/download-artifact@master
       with:
@@ -155,7 +183,9 @@ jobs:
         sudo mv include/* /usr/local/include/
 
     - name: Setup Haskell
-      uses: haskell/actions/setup@v1
+      uses: haskell/actions/setup@v2
+      with:
+        ghc-version: 8
 
     - name: Build & run testsuite
       working-directory: ./src/runtime/haskell
@@ -166,9 +196,13 @@ jobs:
     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@v2
+    - uses: actions/checkout@v3
     - name: Download artifact
       uses: actions/download-artifact@master
       with:
@@ -177,40 +211,159 @@ jobs:
         sudo mv lib/* /usr/local/lib/
         sudo mv include/* /usr/local/include/
 
-    - name: Install bindings
-      working-directory: ./src/runtime/python
+    - name: Install cibuildwheel
       run: |
-        python3 setup.py build
-        sudo python3 setup.py install
+        python3 -m pip install git+https://github.com/joerick/cibuildwheel.git@main
 
-    - name: Run testsuite
-      working-directory: ./src/runtime/python
+    - 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: |
-        pip3 install pytest
-        pytest
+        python3 -m cibuildwheel src/runtime/python --output-dir wheelhouse
 
-  macos-javascript:
-    name: JavaScript (macOS)
-    runs-on: macOS-11
-    needs: macos-runtime
-    if: false
+    - 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@v2
-    - name: Download artifact
-      uses: actions/download-artifact@master
+    - uses: actions/checkout@v3
+    
+    - name: Setup MSYS2
+      uses: msys2/setup-msys2@v2
       with:
-        name: libpgf-macos
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
+        msystem: MINGW64
+        install: >-
+          base-devel
+          autoconf
+          automake
+          libtool
+          mingw-w64-x86_64-toolchain
+          mingw-w64-x86_64-libtool
 
-    - name: Install dependencies
-      working-directory: ./src/runtime/javascript
+    - name: Build runtime
+      shell: msys2 {0}
+      working-directory: ./src/runtime/c
       run: |
-        npm ci
+        autoreconf -i
+        ./configure
+        make
+        make install
 
-    - name: Run testsuite
-      working-directory: ./src/runtime/javascript
+    - 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: |
-        npm run test
+        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/*

.gitignore

@@ -56,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

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::

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,13 +32,41 @@ 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
+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
 ```
-or:
+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
 ```
-stack install
+the same applies for all other dependecies needed here or bellow.
+
+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,81 +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.FilePath((</>),(<.>))
-
-import WebSetup
-
--- | Notice about RGL not built anymore
-noRGLmsg :: IO ()
-noRGLmsg = putStrLn "Notice: the RGL is not built as part of GF anymore. See https://github.com/GrammaticalFramework/gf-rgl"
-
-main :: IO ()
-main = defaultMainWithHooks simpleUserHooks
-  { preBuild  = gfPreBuild
-  , postBuild = gfPostBuild
-  , preInst   = gfPreInst
-  , postInst  = gfPostInst
-  , postCopy  = gfPostCopy
-  }
-  where
-    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`
-    -- However this function should exit quietly to allow building gf in sandbox
-    gfSDist pkg lbi hooks flags = do
-      return ()
-
-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
-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
-          _ -> ""

doc/gf-editor-modes.t2t

@@ -17,9 +17,10 @@ instructions inside.
 
 ==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 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==
 

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/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/transactions.md

@@ -12,7 +12,7 @@ main = do
   -- 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.:
+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
@@ -29,7 +29,7 @@ main = 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 change anymore.
+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
@@ -47,8 +47,6 @@ The last line prints the type of function `"f"` in both the old and the new revi
 
 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: Interprocess synhronization is still not implemented**
-
 **TODO: Merges are still not implemented.**
 
 The process can also ask for the latest revision by calling `checkoutPGF`, see bellow.
@@ -79,6 +77,9 @@ Here we start with an existing revision, apply a transaction and store the resul
 
 # 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,
@@ -107,15 +108,20 @@ From an imperative point of view, it may sound wasteful that a new copy of the g
 
 - 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 will 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.
+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. However, on a fresh database restart we explictly clean all left over 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.
+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
 

index.html

@@ -57,6 +57,8 @@
       <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>
 
     <a href="lib/doc/synopsis/index.html" class="btn btn-primary ml-3">

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

@@ -1,66 +0,0 @@
-module GF.Command.Importing (importGrammar, importSource) where
-
-import PGF2
-import PGF2.Internal(unionPGF)
-
-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 qualified Data.Map as Map
-import Control.Monad(foldM)
-
--- import a grammar in an environment where it extends an existing grammar
-importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
-importGrammar pgf0 _    []    = return pgf0
-importGrammar pgf0 opts files =
-  case takeExtensions (last files) of
-    ".cf"   -> fmap Just $ importCF opts files getBNFCRules bnfc2cf
-    ".ebnf" -> fmap Just $ importCF opts files getEBNFRules ebnf2cf
-    ".gfm"  -> do
-      ascss <- mapM readMulti files
-      let cs = concatMap snd ascss
-      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
-      mapM readPGF files >>= foldM ioUnionPGF pgf0
-    ".ngf" -> do
-      mapM readNGF files >>= foldM ioUnionPGF pgf0
-    ext -> die $ "Unknown filename extension: " ++ show ext
-
-ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)
-ioUnionPGF Nothing    two = return (Just two)
-ioUnionPGF (Just one) two =
-  case unionPGF one two of
-    Nothing         -> putStrLn "Abstract changed, previous concretes discarded." >> return (Just two)
-    Just pgf        -> return (Just pgf)
-
-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"
-      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
-      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
-      return pgf

src/compiler/GF/Command/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/Compile/Compute/Concrete.hs

@@ -1,538 +0,0 @@
-{-# LANGUAGE RankNTypes, CPP #-}
-
--- | Functions for computing the values of terms in the concrete syntax, in
--- | preparation for PMCFG generation.
-module GF.Compile.Compute.Concrete
-           ( normalForm
-           , Value(..), Thunk, ThunkState(..), Env
-           , EvalM, runEvalM, evalError
-           , eval, apply, force, value2term, patternMatch
-           , newMeta,getMeta,setMeta
-           , newThunk,newEvaluatedThunk
-           , getResDef, getInfo, getAllParamValues
-           ) where
-
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-
-import GF.Grammar hiding (Env, VGen, VApp, VRecType)
-import GF.Grammar.Lookup(lookupResDef,lookupOrigInfo,allParamValues)
-import GF.Grammar.Predef
-import GF.Grammar.Lockfield(lockLabel)
-import GF.Grammar.Printer
-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.CheckM
-import GF.Infra.Option
-import Data.STRef
-import Data.Maybe(fromMaybe)
-import Data.List
-import Data.Char
-import Control.Monad
-import Control.Monad.ST
-import Control.Applicative
-import qualified Control.Monad.Fail as Fail
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import PGF2.Transactions(LIndex)
-
--- * Main entry points
-
-normalForm :: Grammar -> Term -> Check Term
-normalForm gr t =
-  fmap mkFV (runEvalM gr (eval [] t [] >>= value2term 0))
-  where
-    mkFV [t] = t
-    mkFV ts  = FV ts
-
-
-data ThunkState s
-  = Unevaluated (Env s) Term
-  | Evaluated (Value s)
-  | Unbound (Maybe Type) {-# UNPACK #-} !MetaId
-
-type Thunk s = STRef s (ThunkState s)
-type Env s = [(Ident,Thunk s)]
-
-data Value s
-  = VApp QIdent [Thunk s]
-  | VMeta (Thunk s) (Env s) [Thunk s]
-  | VSusp (Thunk s) (Env s) [Thunk s] (Thunk s -> EvalM s (Value s))
-  | VGen  {-# UNPACK #-} !Int [Thunk s]
-  | VClosure (Env s) Term
-  | VProd BindType Ident (Value s) (Env s) Term
-  | VRecType [(Label, Value s)]
-  | VR [(Label, Thunk s)]
-  | VP (Value s) Label [Thunk s]
-  | VExtR (Value s) (Value s)
-  | VTable (Value s) (Value s)
-  | VT TInfo (Env s) [Case]
-  | VV Type [Thunk s]
-  | VS (Value s) (Thunk s) [Thunk s]
-  | VSort Ident
-  | VInt Integer
-  | VFlt Double
-  | VStr String
-  | VC [Value s]
-  | VGlue (Value s) (Value s)
-  | VPatt Int (Maybe Int) Patt
-  | VPattType (Value s)
-  | VAlts (Value s) [(Value s, Value s)]
-  | VStrs [Value s]
-    -- This last constructor is only generated internally
-    -- in the PMCFG generator.
-  | VSymCat Int LIndex [(LIndex, Thunk s)]
-
-
-eval env (Vr x)         vs  = case lookup x env of
-                                Just tnk -> force tnk vs
-                                Nothing  -> evalError ("Variable" <+> pp x <+> "is not in scope")
-eval env (Sort s)       []  = return (VSort s)
-eval env (EInt n)       []  = return (VInt n)
-eval env (EFloat d)     []  = return (VFlt d)
-eval env (K t)          []  = return (VStr t)
-eval env Empty          []  = return (VC [])
-eval env (App t1 t2)    vs  = do tnk <- newThunk env t2
-                                 eval env t1 (tnk : vs)
-eval env (Abs b x t)    []  = return (VClosure env (Abs b x t))
-eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
-eval env (Meta i)       vs  = do tnk <- newMeta Nothing i
-                                 return (VMeta tnk env vs)
-eval env (ImplArg t)    []  = eval env t []
-eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 []
-                                 return (VProd b x v1 env t2)
-eval env (Typed t ty)   vs  = eval env t vs
-eval env (RecType lbls) []  = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls
-                                 return (VRecType lbls)
-eval env (R as)         []  = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as
-                                 return (VR as)
-eval env (P t lbl)      vs  = do v <- eval env t []
-                                 case v of
-                                   VR as -> case lookup lbl as of
-                                              Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                                                                     "in record" <+> pp t)
-                                              Just tnk -> force tnk vs
-                                   v     -> return (VP v lbl vs)
-eval env (ExtR t1 t2)   []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 case (v1,v2) of
-                                   (VR       as1,VR       as2) -> return (VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
-                                   (VRecType as1,VRecType as2) -> return (VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2))
-                                   _                           -> return (VExtR v1 v2)
-eval env (Table t1 t2)  []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 return (VTable v1 v2)
-eval env (T i cs)       []  = return (VT i env cs)
-eval env (V ty ts)      []  = do tnks <- mapM (newThunk env) ts
-                                 return (VV ty tnks)
-eval env t@(S t1 t2)    vs  = do v1   <- eval env t1 []
-                                 tnk2 <- newThunk env t2
-                                 let v0 = VS v1 tnk2 vs
-                                 case v1 of
-                                   VT _  env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs)
-                                   VV ty tnks   -> do t2 <- force tnk2 [] >>= value2term (length env)
-                                                      ts <- getAllParamValues ty
-                                                      case lookup t2 (zip ts tnks) of
-                                                        Just tnk -> force tnk vs
-                                                        Nothing  -> return v0
-                                   v1      -> return v0
-eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
-                                     eval ((x,tnk):env) t2 vs
-eval env (Q q@(m,id))   vs
-  | m == cPredef            = do vs' <- mapM (flip force []) vs
-                                 mb_res <- evalPredef id vs'
-                                 case mb_res of
-                                   Just res -> return res
-                                   Nothing  -> return (VApp q vs)
-  | otherwise               = do t <- getResDef q
-                                 eval env t vs
-eval env (QC q)         vs  = return (VApp q vs)
-eval env (C t1 t2)      []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 case (v1,v2) of
-                                   (VC vs1,VC vs2) -> return (VC (vs1++vs2))
-                                   (VC vs1,v2    ) -> return (VC (vs1++[v2]))
-                                   (v1,    VC vs2) -> return (VC ([v1]++vs2))
-                                   (v1,    v2    ) -> return (VC [v1,v2])
-eval env t@(Glue t1 t2) []  = do v1 <- eval env t1 []
-                                 v2 <- eval env t2 []
-                                 case liftM2 (++) (value2string v1) (value2string v2) of
-                                   Just s  -> return (string2value s)
-                                   Nothing -> return (VGlue v1 v2)
-eval env (EPatt min max p) [] = return (VPatt min max p)
-eval env (EPattType t)  []  = do v <- eval env t []
-                                 return (VPattType v)
-eval env (ELincat c ty) []  = do v <- eval env ty []
-                                 let lbl = lockLabel c
-                                     lv  = VRecType []
-                                 case v of
-                                   (VRecType as) -> return (VRecType (update lbl lv as))
-                                   _             -> return (VExtR v (VRecType [(lbl,lv)]))
-eval env (ELin c t)     []  = do v <- eval env t []
-                                 let lbl = lockLabel c
-                                 tnk <- newEvaluatedThunk (VR [])
-                                 case v of
-                                   (VR as) -> return (VR (update lbl tnk as))
-                                   _       -> return (VExtR v (VR [(lbl,tnk)]))
-eval env (FV ts)        vs  = msum [eval env t vs | t <- ts]
-eval env (Alts d as)    []  = do vd <- eval env d []
-                                 vas <- forM as $ \(t,s) -> do
-                                           vt <- eval env t []
-                                           vs <- eval env s []
-                                           return (vt,vs)
-                                 return (VAlts vd vas)
-eval env (Strs ts)      []  = do vs <- mapM (\t -> eval env t []) ts
-                                 return (VStrs vs)
-eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,pv) ->
-                                         case lookup pv env of
-                                           Just tnk -> return (i,tnk)
-                                           Nothing  -> evalError ("Variable" <+> pp pv <+> "is not in scope")
-                                 return (VSymCat d r rs)
-eval env t              vs  = evalError ("Cannot reduce term" <+> pp t)
-
-apply (VMeta m env vs0)             vs  = do st <- getMeta m
-                                             case st of
-                                               Evaluated v -> apply v vs
-                                               Unbound _ _ -> return (VMeta m env (vs0++vs))
-apply (VApp f  vs0)                 vs  = return (VApp f (vs0++vs))
-apply (VGen i  vs0)                 vs  = return (VGen i (vs0++vs))
-apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
-apply v                             []  = return v
-
-evalPredef id [v]
-  | id == cLength = return (fmap VInt (liftM genericLength (value2string v)))
-evalPredef id [v1,v2]
-  | id == cTake   = return (fmap string2value (liftM2 genericTake (value2int v1) (value2string v2)))
-evalPredef id [v1,v2]
-  | id == cDrop   = return (fmap string2value (liftM2 genericDrop (value2int v1) (value2string v2)))
-evalPredef id [v1,v2]
-  | id == cTk     = return (fmap string2value (liftM2 genericTk (value2int v1) (value2string v2)))
-  where
-    genericTk n = reverse . genericTake n . reverse
-evalPredef id [v1,v2]
-  | id == cDp     = return (fmap string2value (liftM2 genericDp (value2int v1) (value2string v2)))
-  where
-    genericDp n = reverse . genericDrop n . reverse
-evalPredef id [v]
-  | id == cIsUpper= return (fmap toPBool (liftM (all isUpper) (value2string v)))
-evalPredef id [v]
-  | id == cToUpper= return (fmap string2value (liftM (map toUpper) (value2string v)))
-evalPredef id [v]
-  | id == cToLower= return (fmap string2value (liftM (map toLower) (value2string v)))
-evalPredef id [v1,v2]
-  | id == cEqStr  = return (fmap toPBool (liftM2 (==) (value2string v1) (value2string v2)))
-evalPredef id [v1,v2]
-  | id == cOccur  = return (fmap toPBool (liftM2 occur (value2string v1) (value2string v2)))
-evalPredef id [v1,v2]
-  | id == cOccurs  = return (fmap toPBool (liftM2 occurs (value2string v1) (value2string v2)))
-evalPredef id [v1,v2]
-  | id == cEqInt  = return (fmap toPBool (liftM2 (==) (value2int v1) (value2int v2)))
-evalPredef id [v1,v2]
-  | id == cLessInt= return (fmap toPBool (liftM2 (<) (value2int v1) (value2int v2)))
-evalPredef id [v1,v2]
-  | id == cPlus   = return (fmap VInt (liftM2 (+) (value2int v1) (value2int v2)))
-evalPredef id [v]
-  | id == cError  = case value2string v of
-                      Just msg -> fail msg
-                      Nothing  -> return Nothing
-evalPredef id vs  = return Nothing
-
-toPBool True  = VApp (cPredef,cPTrue)  []
-toPBool False = VApp (cPredef,cPFalse) []
-
-occur s1 []          = False
-occur s1 s2@(_:tail) = check s1 s2
-  where
-    check xs        []  = False
-    check []        ys  = True
-    check (x:xs) (y:ys)
-      | x == y          = check xs ys
-    check _      _      = occur s1 tail
-
-occurs cs s2 = any (\c -> elem c s2) cs
-
-update lbl v []              = [(lbl,v)]
-update lbl v (a@(lbl',_):as)
-  | lbl==lbl'                = (lbl,v) : as
-  | otherwise                = a : update lbl v as
-
-
-patternMatch v0 []                      = fail "No matching pattern found"
-patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
-  where
-    match env []              eqs      args  = eval env t args
-    match env (PT ty p   :ps) eqs      args  = match env (p:ps) eqs args
-    match env (PAlt p1 p2:ps) eqs      args  = match env (p1:ps) ((env,p2:ps,args,t):eqs) args
-    match env (PM q      :ps) eqs      args  = do t <- getResDef q
-                                                  case t of
-                                                    EPatt _ _ p -> match env (p:ps) eqs args
-                                                    _ -> evalError $ hang "Expected pattern macro:" 4
-                                                                          (pp t)
-    match env (PV v      :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args
-    match env (PAs v p   :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args)
-    match env (PW        :ps) eqs (arg:args) = match env ps eqs args
-    match env (PTilde _  :ps) eqs (arg:args) = match env ps eqs args
-    match env (p         :ps) eqs (arg:args) = do
-      v <- force arg []
-      case (p,v) of
-        (p,       VMeta i envi vs  ) -> return (VSusp i envi vs (\tnk -> match env (p:ps) eqs (tnk:args)))
-        (p,       VGen  i vs       ) -> return v0
-        (p,       VSusp i envi vs k) -> return (VSusp i envi vs (\tnk -> match env (p:ps) eqs (tnk:args)))
-        (PP q qs, VApp r tnks)
-          | q == r        -> match env (qs++ps) eqs (tnks++args)
-        (PR pas, VR as)   -> matchRec env pas as ps eqs args
-        (PString s1, VStr s2)
-          | s1 == s2      -> match env ps eqs args
-        (PString s1, VC [])
-          | null s1       -> match env ps eqs args
-        (PSeq min1 max1 p1 min2 max2 p2,v)
-                          -> case value2string v of
-                               Just s  -> do let n  = length s
-                                                 lo = min1 `max` (n-fromMaybe n max2)
-                                                 hi = (n-min2) `min` fromMaybe n max1
-                                                 (ds,cs) = splitAt lo s
-                                             eqs <- matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
-                                             patternMatch v0 eqs
-                               Nothing -> return v0
-        (PRep minp maxp p, v)
-                          -> case value2string v of
-                               Just s  -> do let n = length s `div` (max minp 1)
-                                             eqs <- matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
-                                             patternMatch v0 eqs
-                               Nothing -> return v0
-        (PChar, VStr [_]) -> match env ps eqs args
-        (PChars cs, VStr [c])
-          | elem c cs     -> match env ps eqs args
-        (PInt n, VInt m)
-          | n == m        -> match env ps eqs args
-        (PFloat n, VFlt m)
-          | n == m        -> match env ps eqs args
-        _                 -> patternMatch v0 eqs
-
-    matchRec env []            as ps eqs args = match env ps eqs args
-    matchRec env ((lbl,p):pas) as ps eqs args =
-      case lookup lbl as of
-        Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl)
-
-    matchStr env ps eqs i ds []     args = do
-      arg1 <- newEvaluatedThunk (string2value (reverse ds))
-      arg2 <- newEvaluatedThunk (string2value [])
-      return ((env,ps,arg1:arg2:args,t) : eqs)
-    matchStr env ps eqs 0 ds cs     args = do
-      arg1 <- newEvaluatedThunk (string2value (reverse ds))
-      arg2 <- newEvaluatedThunk (string2value cs)
-      return ((env,ps,arg1:arg2:args,t) : eqs)
-    matchStr env ps eqs i ds (c:cs) args = do
-      arg1 <- newEvaluatedThunk (string2value (reverse ds))
-      arg2 <- newEvaluatedThunk (string2value (c:cs))
-      eqs  <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
-      return ((env,ps,arg1:arg2:args,t) : eqs)
-
-    matchRep env 0 minp maxp p minq maxq q ps eqs args = do
-      return eqs
-    matchRep env n minp maxp p minq maxq q ps eqs args = do
-      matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args
-
-value2term i (VApp q tnks) =
-  foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (QC q) tnks
-value2term i (VMeta m env tnks) = do
-  res <- zonk m tnks
-  case res of
-    Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Meta i) tnks
-    Left  v -> value2term i v
-value2term i (VSusp j env vs k) = do
-  tnk <- newEvaluatedThunk (VGen maxBound vs)
-  v <- k tnk
-  value2term i v
-value2term i (VGen j tnks) =
-  foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Vr (identS ('v':show j))) tnks
-value2term i (VClosure env (Abs b x t)) = do
-  tnk <- newGen i
-  v <- eval ((x,tnk):env) t []
-  t <- value2term (i+1) v
-  return (Abs b (identS ('v':show i)) t)
-value2term i (VProd b x v1 env t2)
-  | x == identW = do t1 <- value2term i v1
-                     v2 <- eval env t2 []
-                     t2 <- value2term i v2
-                     return (Prod b x t1 t2)
-  | otherwise   = do t1 <- value2term i v1
-                     tnk <- newGen i
-                     v2 <- eval ((x,tnk):env) t2 []
-                     t2 <- value2term (i+1) v2
-                     return (Prod b (identS ('v':show i)) t1 t2)
-value2term i (VRecType lbls) = do
-  lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term i v)) lbls
-  return (RecType lbls)
-value2term i (VR as) = do
-  as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk [] >>= value2term i)) as
-  return (R as)
-value2term i (VP v lbl tnks) = do
-  t <- value2term i v
-  foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (P t lbl) tnks
-value2term i (VExtR v1 v2) = do
-  t1 <- value2term i v1
-  t2 <- value2term i v2
-  return (ExtR t1 t2) 
-value2term i (VTable v1 v2) = do
-  t1 <- value2term i v1
-  t2 <- value2term i v2
-  return (Table t1 t2)
-value2term i (VT ti _ cs) = return (T ti cs)
-value2term i (VV ty tnks) = do ts <- mapM (\tnk -> force tnk [] >>= value2term i) tnks
-                               return (V ty ts)
-value2term i (VS v1 tnk2 tnks) = do t1 <- value2term i v1
-                                    t2 <- force tnk2 [] >>= value2term i
-                                    foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (S t1 t2) tnks
-value2term i (VSort s) = return (Sort s)
-value2term i (VStr tok) = return (K tok)
-value2term i (VInt n) = return (EInt n)
-value2term i (VFlt n) = return (EFloat n)
-value2term i (VC vs) = do
-  ts <- mapM (value2term i) vs
-  case ts of
-    []     -> return Empty
-    (t:ts) -> return (foldl C t ts)
-value2term i (VGlue v1 v2) = do
-  t1 <- value2term i v1
-  t2 <- value2term i v2
-  return (Glue t1 t2)
-value2term i (VPatt min max p) = return (EPatt min max p)
-value2term i (VPattType v) = do t <- value2term i v
-                                return (EPattType t)
-value2term i (VAlts vd vas) = do
-  d <- value2term i vd
-  as <- forM vas $ \(vt,vs) -> do
-           t <- value2term i vt
-           s <- value2term i vs
-           return (t,s)
-  return (Alts d as)
-value2term i (VStrs vs) = do
-  ts <- mapM (value2term i) vs
-  return (Strs ts)
-
-value2string (VStr s) = Just s
-value2string (VC vs)  = fmap unwords (mapM value2string vs)
-value2string _        = Nothing
-
-string2value s =
-  case words s of
-    []  -> VC []
-    [w] -> VStr w
-    ws  -> VC (map VStr ws)
-
-value2int (VInt n) = Just n
-value2int _        = Nothing
-
------------------------------------------------------------------------
--- * Evaluation monad
-
-type MetaThunks s = Map.Map MetaId (Thunk s)
-type Cont s r = MetaThunks s -> r -> ST s (CheckResult r)
-newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r)
-
-instance Functor (EvalM s) where
-  fmap f (EvalM g) = EvalM (\gr k -> g gr (k . f))
-
-instance Applicative (EvalM s) where
-  pure x = EvalM (\gr k -> k x)
-  (EvalM f) <*> (EvalM x) = EvalM (\gr k -> f gr (\f -> x gr (\x -> k (f x))))
-
-instance Monad (EvalM s) where
-  (EvalM f) >>= g = EvalM (\gr k -> f gr (\x -> case g x of
-                                                  EvalM g -> g gr k))
-#if !(MIN_VERSION_base(4,13,0))
-  -- Monad(fail) will be removed in GHC 8.8+
-  fail = Fail.fail
-#endif
-
-instance Fail.MonadFail (EvalM s) where
-  fail msg = EvalM (\gr k _ r -> return (Fail (pp msg)))
-
-instance Alternative (EvalM s) where
-  empty = EvalM (\gr k _ r -> return (Success r))
-  (EvalM f) <|> (EvalM g) = EvalM $ \gr k mt r -> do
-     res <- f gr k mt r
-     case res of
-       Fail msg  -> return (Fail msg)
-       Success r -> g gr k mt r
-
-instance MonadPlus (EvalM s) where
-
-runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a]
-runEvalM gr f =
-  case runST (case f of
-                EvalM f -> f gr (\x mt xs -> return (Success (x:xs))) Map.empty []) of
-    Fail msg   -> checkError msg
-    Success xs -> return (reverse xs)
-
-evalError :: Doc -> EvalM s a
-evalError msg = EvalM (\gr k _ r -> return (Fail msg))
-  
-getResDef :: QIdent -> EvalM s Term
-getResDef q = EvalM $ \gr k mt r -> do
-  case lookupResDef gr q of
-    Ok t    -> k t mt r
-    Bad msg -> return (Fail (pp msg))
-
-getInfo :: QIdent -> EvalM s (ModuleName,Info)
-getInfo q = EvalM $ \gr k mt r -> do
-  case lookupOrigInfo gr q of
-    Ok res  -> k res mt r
-    Bad msg -> return (Fail (pp msg))
-
-getAllParamValues :: Type -> EvalM s [Term]
-getAllParamValues ty = EvalM $ \gr k mt r ->
-  case allParamValues gr ty of
-    Ok ts   -> k ts mt r
-    Bad msg -> return (Fail (pp msg))
-
-newThunk env t = EvalM $ \gr k mt r -> do
- tnk <- newSTRef (Unevaluated env t)
- k tnk mt r
-
-newEvaluatedThunk v = EvalM $ \gr k mt r -> do
- tnk <- newSTRef (Evaluated v)
- k tnk mt r
-
-newMeta mb_ty i = EvalM $ \gr k mt r ->
-  if i == 0
-    then do tnk <- newSTRef (Unbound mb_ty i)
-            k tnk mt r
-    else case Map.lookup i mt of
-           Just tnk -> k tnk mt r
-           Nothing  -> do tnk <- newSTRef (Unbound mb_ty i)
-                          k tnk (Map.insert i tnk mt) r
-
-getMeta tnk    = EvalM $ \gr k mt r -> readSTRef tnk >>= \st -> k st mt r
-
-setMeta tnk st = EvalM $ \gr k mt r -> do
-  old <- readSTRef tnk
-  writeSTRef tnk st
-  r <- k () mt r
-  writeSTRef tnk old
-  return r
-
-newGen i = EvalM $ \gr k mt r -> do
- tnk <- newSTRef (Evaluated (VGen i []))
- k tnk mt r
-
-force tnk vs = EvalM $ \gr k mt r -> do 
-  s <- readSTRef tnk
-  case s of
-    Unevaluated env t -> case eval env t vs of
-                           EvalM f -> f gr (\v mt r -> do writeSTRef tnk (Evaluated v)
-                                                          r <- k v mt r
-                                                          writeSTRef tnk s
-                                                          return r) mt r
-    Evaluated v       -> case apply v vs of
-                           EvalM f -> f gr k mt r
-    Unbound _ _       -> k (VMeta tnk [] vs) mt r
-
-zonk tnk vs = EvalM $ \gr k mt r -> do
-  s <- readSTRef tnk
-  case s of
-    Evaluated v -> case apply v vs of
-                     EvalM f -> f gr (k . Left) mt r
-    Unbound _ i -> k (Right i) mt r

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -1,417 +0,0 @@
--- | 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 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 = do
-  Grammar abstr cncs <- grammar2canonical opts absname gr
-  return [(filename,render80 $ concrete2haskell opts abstr cncmod)
-             | 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
-            LFlt x -> pure (lit x)
-            LInt n -> pure (lit n)
-            LStr 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,182 +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
-    ) where
-
-import GF.Grammar hiding (VApp)
-import GF.Grammar.Predef
-import GF.Grammar.Lookup
-import GF.Infra.CheckM
-import GF.Infra.Option
-import GF.Text.Pretty
-import GF.Compile.Compute.Concrete
-import GF.Data.Operations(Err(..))
-import PGF2.Transactions
-import qualified Data.Map.Strict as Map
-import Control.Monad
-import Data.List(mapAccumL)
-
-generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
-generatePMCFG opts cwd gr cmo@(cm,cmi) = do
-  let gr' = prependModule gr cmo
-  js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi))
-  return (cm,cmi{jments = (Map.fromAscList js)})
-
-addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) =
-  checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ do
-    rules <- pmcfgForm gr term ctxt val
-    return (id,CncFun mty mlin mprn (Just rules))
-addPMCFG opts cwd gr cmi id_info = return id_info
-
-pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [PMCFGRule]
-pmcfgForm gr t ctxt ty =
-  runEvalM gr $ do
-    ((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
-                                   let (ms',_,t) = type2metaTerm gr d ms 0 [] ty
-                                   tnk <- newThunk [] t
-                                   return ((d+1,ms'),tnk))
-                               (0,Map.empty) ctxt
-    sequence_ [newMeta (Just ty) i | (i,ty) <- Map.toList ms]
-    v <- eval [] t args
-    (lins,params) <- flatten v ty ([],[])
-    lins <- mapM str2lin lins
-    (r,rs,_) <- compute params
-    args <- zipWithM tnk2pmcfgcat args ctxt
-    return (PMCFGRule (PMCFGCat r rs) args (reverse lins))
-    where
-      tnk2pmcfgcat tnk (_,_,ty) = do
-        v <- force tnk []
-        (_,params) <- flatten v ty ([],[])
-        (r,rs,_) <- compute params
-        return (PMCFGCat r rs)
-
-      compute []     = return (0,[],1)
-      compute (v:vs) = do
-        (r, rs ,cnt ) <- param2int v
-        (r',rs',cnt') <- compute vs
-        return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
-
-type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,Ident)] -> Type -> (Map.Map MetaId Type,Int,Term)
-type2metaTerm gr d ms r rs (Sort s) | s == cStr =
-  (ms,r+1,TSymCat d r rs)
-type2metaTerm gr d ms r rs (RecType lbls) =
-  let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> let (ms',r',t) = type2metaTerm gr d ms r rs ty
-                                                      in ((ms',r'),(lbl,(Just ty,t))))
-                                 (ms,r) lbls
-  in (ms',r',R ass)  
-type2metaTerm gr d ms r rs (Table p q) =
-  let pv = identS ('p':show (length rs))
-      (ms',r',t) = type2metaTerm gr d ms r ((r'-r,pv):rs) q
-      count = case allParamValues gr p of
-                Ok ts   -> length ts
-                Bad msg -> error msg
-  in (ms',(r'-r)*count,T (TTyped p) [(PV pv,t)])
-type2metaTerm gr d ms r rs ty@(QC q) =
-  let i = Map.size ms + 1
-  in (Map.insert i ty ms,r,Meta i)
-
-
-flatten (VSusp tnk env vs k) ty st = do
-  tnk_st <- getMeta tnk
-  case tnk_st of
-    Evaluated v             -> do v <- apply v vs
-                                  flatten v ty st
-    Unbound (Just (QC q)) _ -> do (m,ResParam (Just (L _ ps)) _) <- getInfo q
-                                  msum [bind tnk m p | p <- ps]
-                                  v <- k tnk
-                                  flatten v ty st
-  where
-    bind tnk m (p, ctxt) = do
-      tnks <- mapM (\(_,_,ty) -> newMeta (Just ty) 0) ctxt
-      setMeta tnk (Evaluated (VApp (m,p) tnks))
-flatten (VR as) (RecType lbls) st = do
-  foldM collect st lbls
-  where
-    collect st (lbl,ty) =
-      case lookup lbl as of
-        Just tnk -> do v <- force tnk []
-                       flatten v ty st
-        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
-                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
-flatten v@(VT _ env cs) (Table p q) st = do
-  ts <- getAllParamValues p
-  foldM collect st ts
-  where
-    collect st t = do
-      tnk <- newThunk [] t
-      let v0 = VS v tnk []
-      v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
-      flatten v q st
-flatten (VV _ tnks) (Table _ q) st = do
-  foldM collect st tnks
-  where
-    collect st tnk = do
-      v <- force tnk []
-      flatten v q st
-flatten v (Sort s) (lins,params) | s == cStr = do
-  return (v:lins,params)
-flatten v (QC q) (lins,params) = do
-  return (lins,v:params)
-
-str2lin (VStr s)         = return [SymKS s]
-str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
-                              return [SymCat d r rs]
-  where
-    compute r' []                = return (r',[])
-    compute r' ((cnt',tnk):tnks) = do
-      (r, rs,_) <- force tnk [] >>= param2int
-      (r',rs' ) <- compute r' tnks
-      return (r*cnt'+r',combine cnt' rs rs')
-str2lin (VC vs)          = fmap concat (mapM str2lin vs)
-str2lin v                = do t <- value2term 0 v
-                              evalError ("the term" <+> ppTerm Unqualified 0 t $$
-                                         "cannot be evaluated at compile time.")
-
-param2int (VApp q tnks) = do
-  (r ,    cnt ) <- getIdxCnt q
-  (r',rs',cnt') <- compute tnks
-  return (r*cnt' + r',rs',cnt*cnt')
-  where
-    getIdxCnt q = do
-      (_,ResValue (L _ ty) idx) <- getInfo q
-      let QC p = valTypeCnc ty
-      (_,ResParam _ (Just (_,cnt))) <- getInfo p
-      return (idx,cnt)
-
-    compute []         = return (0,[],1)
-    compute (tnk:tnks) = do
-      (r, rs ,cnt ) <- force tnk [] >>= param2int
-      (r',rs',cnt') <- compute tnks
-      return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
-param2int (VMeta tnk _ _) = do
-  tnk_st <- getMeta tnk
-  case tnk_st of
-    Evaluated v         -> param2int v
-    Unbound (Just ty) j -> do let QC q = valTypeCnc ty
-                              (_,ResParam _ (Just (_,cnt))) <- getInfo q
-                              return (0,[(1,j)],cnt)
-
-combine cnt'          []            rs' = rs'
-combine cnt'         rs              [] = [(r*cnt',pv) | (r,pv) <- rs]
-combine cnt' ((r,pv):rs) ((r',pv'):rs') =
-  case compare pv pv' of
-    LT -> (r*cnt',   pv ) : combine cnt' rs ((r',pv'):rs')
-    EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
-    GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
-
-mapAccumM f a []     = return (a,[])
-mapAccumM f a (x:xs) = do (a, y) <- f a x
-                          (a,ys) <- mapAccumM f a xs
-                          return (a,y:ys)
-
-pgfCncCat = error "TODO: pgfCncCat"

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -1,424 +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.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
-import GF.Infra.Option(Options,optionsPGF)
-import GF.Infra.CheckM
-import PGF2(Literal(..))
-import GF.Compile.Compute.Concrete(normalForm)
-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 -> Check C.Grammar
-grammar2canonical opts absname gr = do
-  abs <- abstract2canonical absname gr
-  cncs <- concretes2canonical opts absname gr
-  return (Grammar abs (map snd cncs))
-
--- | Generate Canonical code for the named abstract syntax
-abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
-abstract2canonical absname gr =
-  return (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 -> Check [(FilePath, Concrete)]
-concretes2canonical opts absname gr =
-  sequence
-    [fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod)
-        | 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 -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete
-concrete2canonical gr absname cnc modinfo = do
-  defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo))
-  return (Concrete (modId cnc) (modId absname) (convFlags gr cnc)
-                   (neededParamTypes S.empty (params defs))
-                   [lincat | (_,Left lincat) <- defs]
-                   [lin | (_,Right lin) <- defs])
-  where
-    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 -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
-toCanonical gr absname (name,jment) =
-  case jment of
-    CncCat (Just (L loc typ)) _ _ pprn _ -> do
-      ntyp <- normalForm gr typ
-      let pts = paramTypes gr ntyp
-      return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
-    CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
-      let params = [(b,x)|(b,x,_)<-ctx]
-          args   = map snd params
-      e0 <- normalForm gr (mkAbs params (mkApp def (map Vr args)))
-      let e   = cleanupRecordFields lincat (unAbs (length params) e0)
-          tts = tableTypes gr [e]
-      return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]
-    AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
-                     Ok (m,jment) -> toCanonical gr absname (name,jment)
-                     _ -> return []
-    _ -> return []
-  where
-    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 (LInt 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 (LStr s)
-        Empty -> LiteralValue (LStr "")
-        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 = error "TODO: ppPredef" {-
-      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 (LStr ""),_) -> v2
-    (_,LiteralValue (LStr "")) -> 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,v) |
-         (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]

src/compiler/GF/Compile/PGFtoJSON.hs

@@ -1,111 +0,0 @@
-module GF.Compile.PGFtoJSON (pgf2json) where
-
-import PGF2
-import PGF2.Internal
-import Text.JSON
-import qualified Data.Map as Map
-
-pgf2json :: PGF -> String
-pgf2json pgf = error "TODO: pgf2json"
-{-  encode $ makeObj
-    [ ("abstract", abstract2json pgf)
-    , ("concretes", makeObj $ map concrete2json
-                                (Map.toList (languages pgf)))
-    ]
-
-abstract2json :: PGF -> JSValue
-abstract2json pgf =
-  makeObj
-    [ ("name", showJSON (abstractName pgf))
-    , ("startcat", showJSON (showType [] (startCat pgf)))
-    , ("funs", makeObj $ map (absdef2json pgf) (functions pgf))
-    ]
-
-absdef2json :: PGF -> Fun -> (String,JSValue)
-absdef2json pgf f = (f,sig)
-  where
-    Just (hypos,cat,_) = fmap unType (functionType pgf f)
-    sig = makeObj
-      [ ("args", showJSON $ map (\(_,_,ty) -> showType [] ty) hypos)
-      , ("cat", showJSON cat)
-      ]
-
-lit2json :: Literal -> JSValue
-lit2json (LStr s) = showJSON s
-lit2json (LInt n) = showJSON n
-lit2json (LFlt d) = showJSON d
-
-concrete2json :: (ConcName,Concr) -> (String,JSValue)
-concrete2json (c,cnc) = (c,obj)
-  where
-    obj = makeObj
-      [ ("flags", makeObj [(k, lit2json v) | (k,v) <- concrFlags cnc])
-      , ("productions", makeObj [(show fid, showJSON (map frule2json (concrProductions cnc fid))) | (_,start,end,_) <- concrCategories cnc, fid <- [start..end]])
-      , ("functions", showJSON [ffun2json funid (concrFunction cnc funid) | funid <- [0..concrTotalFuns cnc-1]])
-      , ("sequences", showJSON [seq2json seqid (concrSequence cnc seqid) | seqid <- [0..concrTotalSeqs cnc-1]])
-      , ("categories", makeObj $ map cat2json (concrCategories cnc))
-      , ("totalfids", showJSON (concrTotalCats cnc))
-      ]
-
-cat2json :: (Cat,FId,FId,[String]) -> (String,JSValue)
-cat2json (cat,start,end,_) = (cat, ixs)
-  where
-    ixs = makeObj
-      [ ("start", showJSON start)
-      , ("end",   showJSON end)
-      ]
-
-frule2json :: Production -> JSValue
-frule2json (PApply fid args) =
-  makeObj
-    [ ("type", showJSON "Apply")
-    , ("fid",  showJSON fid)
-    , ("args", showJSON (map farg2json args))
-    ]
-frule2json (PCoerce arg) =
-  makeObj
-    [ ("type", showJSON "Coerce")
-    , ("arg",  showJSON arg)
-    ]
-
-farg2json :: PArg -> JSValue
-farg2json (PArg hypos fid) =
-  makeObj
-    [ ("type", showJSON "PArg")
-    , ("hypos", JSArray $ map (showJSON . snd) hypos)
-    , ("fid", showJSON fid)
-    ]
-
-ffun2json :: FunId -> (Fun,[SeqId]) -> JSValue
-ffun2json funid (fun,seqids) =
-  makeObj
-    [ ("name", showJSON fun)
-    , ("lins", showJSON seqids)
-    ]
-
-seq2json :: SeqId -> [Symbol] -> JSValue
-seq2json seqid seq = showJSON [sym2json sym | sym <- seq]
-
-sym2json :: Symbol -> JSValue
-sym2json (SymCat n l)    = new "SymCat" [showJSON n, showJSON l]
-sym2json (SymLit n l)    = new "SymLit" [showJSON n, showJSON l]
-sym2json (SymVar n l)    = new "SymVar" [showJSON n, showJSON l]
-sym2json (SymKS t)       = new "SymKS"  [showJSON t]
-sym2json (SymKP ts alts) = new "SymKP"  [JSArray (map sym2json ts), JSArray (map alt2json alts)]
-sym2json SymBIND         = new "SymKS"  [showJSON "&+"]
-sym2json SymSOFT_BIND    = new "SymKS"  [showJSON "&+"]
-sym2json SymSOFT_SPACE   = new "SymKS"  [showJSON "&+"]
-sym2json SymCAPIT        = new "SymKS"  [showJSON "&|"]
-sym2json SymALL_CAPIT    = new "SymKS"  [showJSON "&|"]
-sym2json SymNE           = new "SymNE"  []
-
-alt2json :: ([Symbol],[String]) -> JSValue
-alt2json (ps,ts) = new "Alt" [showJSON (map sym2json ps), showJSON ts]
-
-new :: String -> [JSValue] -> JSValue
-new f xs =
-  makeObj
-    [ ("type", showJSON f)
-    , ("args", showJSON xs)
-    ]
--}

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

@@ -1,835 +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 Data.Maybe(fromMaybe)
-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
-     let (minp,maxp,p') = measurePatt gr p
-     return (EPatt minp maxp p', 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
-     (term',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
-
-measurePatt gr p =
-  case p of
-    PM q       -> case lookupResDef gr q of
-                    Ok t    -> case t of
-                                 EPatt minp maxp _ -> (minp,maxp,p)
-                                 _ -> error "Expected pattern macro"
-                    Bad msg -> error msg
-    PR ass     -> let p' = PR (map (\(lbl,p) -> let (_,_,p') = measurePatt gr p in (lbl,p')) ass)
-                  in (0,Nothing,p')
-    PString s  -> let len=length s
-                  in (len,Just len,p)
-    PT t p     -> let (min,max,p') = measurePatt gr p
-                  in (min,max,PT t p')
-    PAs x p    -> let (min,max,p') = measurePatt gr p
-                  in (min,max,PAs x p')
-    PImplArg p -> let (min,max,p') = measurePatt gr p
-                  in (min,max,PImplArg p')
-    PNeg p     -> let (_,_,p') = measurePatt gr p
-                  in (0,Nothing,PNeg p')
-    PAlt p1 p2 -> let (min1,max1,p1') = measurePatt gr p1
-                      (min2,max2,p2') = measurePatt gr p2
-                  in (min min1 min2,liftM2 max max1 max2,PAlt p1' p2')
-    PSeq _ _ p1 _ _ p2
-               -> let (min1,max1,p1') = measurePatt gr p1
-                      (min2,max2,p2') = measurePatt gr p2
-                  in (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1' min2 max2 p2')
-    PRep _ _ p -> let (minp,maxp,p') = measurePatt gr p
-                  in (0,Nothing,PRep minp maxp p')
-    PChar      -> (1,Just 1,p)
-    PChars _   -> (1,Just 1,p)
-    _          -> (0,Nothing,p)
-
--- 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
-     let (_,_,p') = measurePatt gr p
-     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.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 :: Grammar -> Term -> Type -> Check (Term, Type)
-checkLType ge t ty = error "TODO: checkLType" {- runTcM $ do
-  vty <- liftErr (eval ge [] ty)
-  (t,_) <- tcRho ge [] t (Just vty)
-  t <- zonkTerm t
-  return (t,ty) -}
-
-inferLType :: Grammar -> Term -> Check (Term, Type)
-inferLType ge t = error "TODO: inferLType" {- 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 x = TcM (\ms msgs -> TcOk x ms msgs)
-  f >>= g  = TcM (\ms msgs -> case unTcM f ms msgs of
-                                TcOk x ms msgs -> unTcM (g x) ms msgs
-                                TcFail    msgs -> TcFail msgs)
-
-#if !(MIN_VERSION_base(4,13,0))
-  -- Monad(fail) will be removed in GHC 8.8+
-  fail = Fail.fail
-#endif
-
-instance Fail.MonadFail TcM where
-  fail     = tcError . pp
-
-
-instance Applicative TcM where
-  pure = return
-  (<*>) = ap
-
-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)],2)))
-  , (cPTrue    , ResValue (noLoc typePBool) 0)
-  , (cPFalse   , ResValue (noLoc typePBool) 1)
-  , (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,304 +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)
-import PGF(Literal(..))
-
--- | 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 Literal
-              | 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 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,Literal)] deriving Show
-type FlagName = Id
-
-
--- *** 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 Literal where pp = ppA
-
-instance PPA Literal where
-  ppA l = case l of
-            LFlt f -> pp f
-            LInt n -> pp n
-            LStr 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 <>";"
-
---------------------------------------------------------------------------------
--- | 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,289 +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)
-import PGF(Literal(..))
-
-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 Literal where
-  -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
-  showJSON (LStr s) = showJSON s
-  showJSON (LFlt f) = showJSON f
-  showJSON (LInt n) = showJSON n
-
-  readJSON = readBasicJSON LStr LInt LFlt
-
-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)
-
---------------------------------------------------------------------------------
--- ** 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,183 +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
-                               ) where
-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Macros
---import GF.Grammar.Printer
-
-import Data.Maybe(fromMaybe)
-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 min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s
-
-      (PRep _ _ p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (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)
-
-matchPSeq min1 max1 p1 min2 max2 p2 s =
-  do let n = length s
-         lo = min1 `max` (n-fromMaybe n max2)
-         hi = (n-min2) `min` (fromMaybe n max1)
-         cuts = [splitAt i s | i <- [lo..hi]]
-     matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
-     return (concat matches)
-
-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/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,438 +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(HasPGF(..),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 PGF2
-
-import Data.Char
-import Data.List(isPrefixOf)
-import qualified Data.Map as Map
-import qualified Text.ParserCombinators.ReadP as RP
-import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
-import Control.Exception(SomeException,fromException,evaluate,try)
-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
-  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,pgf)}
-      else do pgf1 <- lift $ importPGF pgf0
-              modify $ \ gfenv->gfenv { retain=False,
-                                        pgfenv = (emptyGrammar,pgf1) }
-  where
-    importPGF pgf0 =
-      do let opts' = addOptions (setOptimization OptCSE False) opts
-         pgf1 <- importGrammar pgf0 opts' files
-         if (verbAtLeast opts Normal)
-           then case pgf1 of
-                  Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
-                  Nothing  -> return ()
-           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 = "> "
-  | otherwise  = case multigrammar env of
-                   Just pgf -> abstractName pgf ++ "> "
-                   Nothing  -> "> "
-
-type CmdEnv = (Grammar,Maybe PGF)
-
-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,Nothing)
-
-emptyCommandEnv = mkCommandEnv allCommands
-multigrammar = snd . pgfenv
-
-allCommands =
-  extend pgfCommands (helpCommand allCommands:moreCommands)
-  `Map.union` sourceCommands
-  `Map.union` commonCommands
-
-instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv)
-instance HasPGF ShellM where getPGF = gets (snd . pgfenv)
-
-wordCompletion gfenv (left,right) = do
-  case wc_type (reverse left) of
-    CmplCmd pref
-      -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
-    CmplStr (Just (Command _ opts _)) s0
-      -> case multigrammar gfenv of
-           Just pgf -> let langs = languages pgf
-                           optLang opts = case valStrOpts "lang" "" opts of
-                                            ""   -> case Map.minView langs of
-                                                      Nothing        -> Nothing
-                                                      Just (concr,_) -> Just concr
-                                            lang -> mplus (Map.lookup lang                       langs)
-                                                          (Map.lookup (abstractName pgf ++ lang) langs)
-                           optType opts = let readOpt str = case readType str of
-                                                              Just ty -> case checkType pgf ty of
-                                                                           Left _   -> Nothing
-                                                                           Right ty -> Just ty
-                                                              Nothing -> Nothing
-                                          in maybeStrOpts "cat" (Just (startCat pgf)) readOpt opts
-                           (rprefix,rs) = break isSpace (reverse s0)
-                           s            = reverse rs
-                           prefix       = reverse rprefix
-                       in case (optLang opts, optType opts) of
-                            (Just lang,Just cat) -> let compls = [t | ParseOk res <- [complete lang cat s prefix], (t,_,_,_) <- res]
-                                                    in ret (length prefix) (map Haskeline.simpleCompletion compls)
-                            _                    -> ret 0 []
-           Nothing  -> ret 0 []
-    CmplOpt (Just (Command n _ _)) pref
-      -> case Map.lookup n (commands cmdEnv) of
-           Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags   inf, isPrefixOf pref flg]
-                              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 multigrammar gfenv of
-           Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
-           Nothing  -> ret (length pref) []
-    _ -> ret 0 []
-  where
-    cmdEnv = commandenv gfenv
-
-    loop ps []     = Just ps
-    loop ps (t:ts) = case error "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/Setup.hs

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

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

@@ -74,10 +74,16 @@ import qualified Data.ByteString.Internal as S
 #endif
 
 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
-import GHC.Base(Int(..),uncheckedShiftRL# )
+import GHC.Base(Int(..),uncheckedShiftRL#,)
 import GHC.Word (Word32(..),Word16(..),Word64(..))
 
-#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608
+#if MIN_VERSION_base(4,16,0)
+import GHC.Exts (wordToWord16#, word16ToWord#, wordToWord32#, word32ToWord#)
+#endif
+#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 
+import GHC.Word (uncheckedShiftRL64#)
+#endif
+#if __GLASGOW_HASKELL__ >= 900 
 import GHC.Word (uncheckedShiftRL64#)
 #endif
 #endif
@@ -411,8 +417,14 @@ shiftr_w32 :: Word32 -> Int -> Word32
 shiftr_w64 :: Word64 -> Int -> Word64
 
 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#if MIN_VERSION_base(4,16,0)
+shiftr_w16 (W16# w) (I# i) = W16# (wordToWord16# ((word16ToWord# w) `uncheckedShiftRL#`   i))
+shiftr_w32 (W32# w) (I# i) = W32# (wordToWord32# ((word32ToWord# w) `uncheckedShiftRL#`   i))
+#else
 shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#`   i)
 shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#`   i)
+#endif
+
 
 #if WORD_SIZE_IN_BITS < 64
 shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
@@ -424,7 +436,11 @@ foreign import ccall unsafe "stg_uncheckedShiftRL64"
 #endif
 
 #else
+#if __GLASGOW_HASKELL__ <= 810
 shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
+#else
+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
+#endif
 #endif
 
 #else

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

@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP, MagicHash #-}
+-- This module makes profiling a lot slower, so don't add automatic cost centres 
+{-# OPTIONS_GHC -fno-prof-auto #-}
 -- for unboxed shifts
 
 -----------------------------------------------------------------------------
@@ -99,6 +101,12 @@ import Data.STRef
 import GHC.Base
 import GHC.Word
 --import GHC.Int
+#if MIN_VERSION_base(4,16,0)
+import GHC.Exts (wordToWord16#, word16ToWord#, wordToWord32#, word32ToWord#)
+#endif
+#if __GLASGOW_HASKELL__ >= 900 
+import GHC.Word (uncheckedShiftL64#)
+#endif
 #endif
 
 -- Control.Monad.Fail import will become redundant in GHC 8.8+
@@ -530,8 +538,13 @@ shiftl_w32 :: Word32 -> Int -> Word32
 shiftl_w64 :: Word64 -> Int -> Word64
 
 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#if MIN_VERSION_base(4,16,0)
+shiftl_w16 (W16# w) (I# i) = W16# (wordToWord16# ((word16ToWord# w) `uncheckedShiftL#`   i))
+shiftl_w32 (W32# w) (I# i) = W32# (wordToWord32# ((word32ToWord# w) `uncheckedShiftL#`   i))
+#else
 shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#`   i)
 shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)
+#endif
 
 #if WORD_SIZE_IN_BITS < 64
 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
@@ -543,7 +556,12 @@ foreign import ccall unsafe "stg_uncheckedShiftL64"
 #endif
 
 #else
+#if __GLASGOW_HASKELL__ <= 810
 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
+#else
+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
+#endif
+
 #endif
 
 #else

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 PGF2(Expr,showExpr)
+import PGF2
 import GF.Grammar.Grammar(Term)
 
 type Ident = String
@@ -13,15 +13,22 @@ data Command
    = Command Ident [Option] Argument
    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
@@ -33,9 +40,19 @@ data Argument
 
 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 =
@@ -45,8 +62,8 @@ valStrOpts flag def opts =
 
 maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
 maybeIntOpts flag def fn opts =
-  case [v | OFlag f (VInt v) <- opts, f == flag] of
-    (v:_) -> fn v
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fn (fromIntegral v)
     _     -> def
 
 maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
@@ -59,9 +76,9 @@ 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,8 +1,8 @@
 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 PGF2(mkStr,unStr,showExpr)
 
 data CommandInfo m = CommandInfo {
@@ -73,8 +73,8 @@ toExprs args =
 toTerm args =
   case args of
     Term t -> t
-    Strings ss -> string2term $ unwords ss -- hmm
-    Exprs es -> string2term $ unwords $ map (showExpr [] . fst) es -- hmm
+    Strings ss -> K $ unwords ss -- hmm
+    Exprs es -> K $ unwords $ map (showExpr [] . fst) es -- hmm
 
 -- ** Creating documentation
 

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

@@ -3,7 +3,8 @@ module GF.Command.Commands (
   HasPGF(..),pgfCommands,
   options,flags,
   ) where
-import Prelude hiding (putStrLn,(<>))
+import Prelude hiding (putStrLn,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+import System.Info(os)
 
 import PGF2
 
@@ -31,8 +32,6 @@ import GF.Text.Pretty
 import Data.List (sort)
 import Control.Monad(mplus)
 import qualified Control.Monad.Fail as Fail
---import Debug.Trace
-
 
 class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF)
 
@@ -44,7 +43,7 @@ instance (Monad m,HasPGF m,Fail.MonadFail m) => TypeCheckArg m where
                                            (inferExpr pgf e)
                         Nothing  -> fail "Import a grammar before using this command"
 
-pgfCommands :: HasPGF m => Map.Map String (CommandInfo m)
+pgfCommands :: (HasPGF m, Fail.MonadFail m) => Map.Map String (CommandInfo m)
 pgfCommands = Map.fromList [
   ("aw", emptyCommandInfo {
      longname = "align_words",
@@ -165,29 +164,32 @@ pgfCommands = Map.fromList [
        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 ?))"
+       mkEx "gr (AdjCN ? (UseN ?))  -- fills in the metavariables in the expression"
        ],
      explanation = unlines [
        "Generates a list of random trees, by default one tree.",
-       "If a tree argument is given, the command completes the Tree with values to",
-       "all metavariables in the tree. The generation can be biased by probabilities",
-       "if the grammar was compiled with option -probs"
+       "If a tree argument is given, the command fills in",
+       "the metavariables in the tree with values. The generation is",
+       "biased by probabilities if the grammar was compiled with",
+       "option -probs."
        ],
      options = [
        ("show_probs", "show the probability of each result")
        ],
      flags = [
        ("cat","generation category"),
+       ("depth","the maximum generation depth, default 4"),
        ("lang","uses only functions that have linearizations in all these languages"),
        ("number","number of trees generated")
        ],
      exec = needPGF $ \opts arg pgf -> do
        gen <- newStdGen
-       let ts  = case mexp (toExprs arg) of
-                   Just ex -> generateRandomFrom gen pgf ex
-                   Nothing -> generateRandom     gen pgf (optType pgf opts)
-       returnFromExprs (isOpt "show_probs" opts) $ take (optNum opts) ts
+       let dp = valIntOpts "depth" 4 opts
+           langs = optLangs pgf opts
+           es = case mexp (toExprs arg) of
+                   Just ex -> generateRandomFromExt gen pgf ex dp langs
+                   Nothing -> generateRandomExt     gen pgf (optType pgf opts) dp langs
+       returnFromExprs (isOpt "show_probs" opts) $ take (optNum opts) es
      }),
 
   ("gt", emptyCommandInfo {
@@ -195,26 +197,32 @@ pgfCommands = Map.fromList [
      synopsis = "generates a list of trees, by default exhaustive",
      explanation = unlines [
        "Generates all trees of a given category.",
-       "If a Tree argument is given, the command completes the Tree with values",
-       "to all metavariables in the tree."
+       "If a tree argument is given, the command completes",
+       "the metavariables in the tree with values.",
+       "The generated trees are listed in decreasing probability order",
+       "(increasing negated log-probability)."
        ],
      options = [
        ("show_probs", "show the probability of each result")
        ],
      flags = [
        ("cat","the generation category"),
-       ("lang","excludes functions that have no linearization in this language"),
+       ("depth","the maximum generation depth, default 4"),
+       ("lang","uses only functions that have linearizations in all these languages"),
        ("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",
+       mkEx "gt                     -- all trees in the startcat with maximal depth 4",
+       mkEx "gt -cat=NP -number=16  -- 16 trees in the category NP with maximal depth 4",
+       mkEx "gt -cat=NP -depth=2    -- all trees in the category NP with up to depth 2",
        mkEx "gt (AdjCN ? (UseN ?))  -- trees of form (AdjCN ? (UseN ?))"
        ],
      exec = needPGF $ \opts arg pgf -> do
-       let es = case mexp (toExprs arg) of
-                  Just ex -> generateAllFrom pgf ex
-                  Nothing -> generateAll     pgf (optType pgf opts)
+       let dp = valIntOpts "depth" 4 opts
+           langs = optLangs pgf opts
+           es = case mexp (toExprs arg) of
+                  Just ex -> generateAllFromExt pgf ex dp langs
+                  Nothing -> generateAllExt     pgf (optType pgf opts) dp langs
        returnFromExprs (isOpt "show_probs" opts) $ takeOptNum opts es
      }),
 
@@ -239,6 +247,7 @@ pgfCommands = Map.fromList [
        ],
      options = [
        ("retain","retain operations (used for cc command)"),
+       ("resource","the grammar is loaded as a resource to a precompiled PGF"),
        ("src",   "force compilation from source"),
        ("v",     "be verbose - show intermediate status information")
        ],
@@ -276,31 +285,49 @@ pgfCommands = Map.fromList [
 
   ("ma", emptyCommandInfo {
      longname = "morpho_analyse",
-     synopsis = "print the morphological analyses of all words in the string",
+     synopsis = "print the morphological analyses of words in the string",
      explanation = unlines [
-       "Prints all the analyses of space-separated words in the input string,",
-       "using the morphological analyser of the actual grammar (see command pg)"
+       "Prints all the analyses of words in the input string.",
+       "By default it assumes that the input consists of a single lexical expression,",
+       "but if one of the options bellow is used then the command tries to",
+       "separate the text into units. Some of the units may be multi-word expressions,",
+       "others punctuations, or morphemes not separated by spaces."
        ],
      exec  = needPGF $ \opts ts pgf -> do
                concr <- optLang pgf opts
                case opts of
-                 _ | isOpt "missing" opts ->
-                      return . fromString . unwords .
-                      morphoMissing concr .
-                      concatMap words $ toStrings ts
+                 _ | isOpt "all" opts ->
+                      return . fromString . unlines .
+                      map prCohortAnalysis . concatMap (morphoCohorts id concr) $
+                      toStrings ts
+                 _ | isOpt "longest" opts ->
+                      return . fromString . unlines .
+                      map prCohortAnalysis . concatMap (morphoCohorts filterLongest concr) $
+                      toStrings ts
+                 _ | isOpt "best" opts ->
+                      return . fromString . unlines .
+                      map prCohortAnalysis . concatMap (morphoCohorts filterBest concr) $
+                      toStrings ts
                  _ | isOpt "known" opts ->
                       return . fromString . unwords .
-                      morphoKnown concr .
-                      concatMap words $ toStrings ts
+                      concatMap (morphoKnown concr) $
+                      toStrings ts
+                 _ | isOpt "missing" opts ->
+                      return . fromString . unwords .
+                      concatMap (morphoMissing concr) $
+                      toStrings ts
                  _ -> return . fromString . unlines .
-                      map prMorphoAnalysis . concatMap (morphos pgf opts) .
-                      concatMap words $ toStrings ts,
+                      map prMorphoAnalysis . concatMap (morphos pgf opts) $
+                      toStrings ts,
      flags = [
        ("lang","the languages of analysis (comma-separated, no spaces)")
        ],
      options = [
-       ("known",  "return only the known words, in order of appearance"),
-       ("missing","show the list of unknown words, in order of appearance")
+       ("all",    "scan the text for all words, not just a single one"),
+       ("longest","scan the text for all words, and apply longest match filtering"),
+       ("best",   "scan the text for all words, and apply global best match filtering"),
+       ("known",  "list all known words, in order of appearance"),
+       ("missing","list all missing words, in order of appearance")
        ]
      }),
 
@@ -369,7 +396,7 @@ pgfCommands = Map.fromList [
      exec  = needPGF $ \opts _ pgf -> prGrammar pgf opts,
      flags = [
        ("file",   "set the file name when printing with -pgf option"),
-       ("lang",   "select languages for the some options (default all languages)"),
+       ("lang",   "select languages for some options (default all languages)"),
        ("printer","select the printing format (see flag values above)")
        ],
      options = [
@@ -380,7 +407,7 @@ pgfCommands = Map.fromList [
        ("lexc", "print the lexicon in Xerox LEXC format"),
        ("missing","show just the names of functions that have no linearization"),
        ("opt",    "optimize the generated pgf"),
-       ("pgf",    "write current pgf image in file"),
+       ("pgf",    "write the current pgf image in a file"),
        ("words", "print the list of words")
        ],
      examples = [
@@ -561,12 +588,8 @@ pgfCommands = Map.fromList [
                                           nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts,
                                           leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
                                          }
-         let depfile = valStrOpts "file" "" opts
          concr  <- optLang pgf opts
-         mlab <- case depfile of
-           "" -> return Nothing
-           _  -> (Just . getDepLabels) `fmap` restricted (readFile depfile)
-         let grphs = map (graphvizDependencyTree "dot" False mlab Nothing concr) es
+         let grphs = map (graphvizParseTree concr gvOptions) es
          if isFlag "view" opts || isFlag "format" opts
            then do
              let view = optViewGraph opts
@@ -623,8 +646,8 @@ pgfCommands = Map.fromList [
          mapM_ putStrLn ss
          return void
        else do
-         let funs = not (isOpt "nofun" opts)
-         let cats = not (isOpt "nocat" opts)
+         let funs = isOpt "nofun" opts
+         let cats = isOpt "nocat" opts
          let grphs = map (graphvizAbstractTree pgf (graphvizDefaults{noFun=funs,noCat=cats})) es
          if isFlag "view" opts || isFlag "format" opts
            then do
@@ -653,12 +676,12 @@ pgfCommands = Map.fromList [
      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.",
+       "The command has one argument which is either a function, an 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."
+       "If a whole expression is given, then it prints the expression with refined",
+       "metavariables as well as the type of the expression."
        ],
      exec = needPGF $ \opts arg pgf -> do
        case toExprs arg of
@@ -678,7 +701,7 @@ pgfCommands = Map.fromList [
                                                   Nothing    -> do putStrLn ("unknown category of function identifier "++show id)
                                                                    return void
                   _             -> case inferExpr pgf e of
-                                     Left err     -> error err
+                                     Left err     -> errorWithoutStackTrace err
                                      Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
                                                         putStrLn ("Type:        "++showType [] ty)
                                                         putStrLn ("Probability: "++show (exprProbability pgf e))
@@ -686,13 +709,71 @@ pgfCommands = Map.fromList [
          _           -> do putStrLn "a single identifier or expression is expected from the command"
                            return void,
      needsTypeCheck = False
+     }),
+  ("c", emptyCommandInfo {
+     longname = "create",
+     syntax = "create fun f = ..; create cat c = ..; create concrete l; create lin c = ..; or create lincat c = ..",
+     synopsis = "Dynamically adds new functions, categories and languages to the current grammar.",
+     explanation = unlines [
+       "After the command you can write fun, data, cat, concrete, lin or a lincat definition.",
+       "The syntax is the same as if the definition was in a module. If you want to use",
+       "any operations inside lin and lincat, you should import them",
+       "by using the command `i -resource <file path>`."
+       ],
+     flags = [
+       ("lang","the language to which to add a lin or a lincat"),
+       ("prob","the probability for a new abstract function")
+       ],
+     needsTypeCheck = False
+     }),
+  ("a", emptyCommandInfo {
+     longname = "alter",
+     syntax = "alter lin f = ..",
+     synopsis = "Dynamically updates the linearization of a function in the current grammar.",
+     explanation = unlines [
+       "The syntax is the same as if the definition was in a module. If you want to use",
+       "any operations inside the lin definition, you should import them",
+       "by using the command `i -resource <file path>`."
+       ],
+     flags = [
+       ("lang","the language in which to alter the lin")
+       ],
+     needsTypeCheck = False
+     }),
+  ("d", emptyCommandInfo {
+     longname = "drop",
+     syntax = "drop fun f; drop cat c; drop concrete l; drop lin c; or drop lincat c",
+     synopsis = "Dynamically removes functions, categories and languages from the current grammar.",
+     explanation = unlines [
+       "After the command you must specify whether you want to remove",
+       "fun, data, cat, concrete, lin or a lincat definition.",
+       "Note that if you are removing an abstract function or category,",
+       "then all corresponding linearizations will be dropped as well."
+       ],
+     flags = [
+       ("lang","the language from which to remove the lin or the lincat")
+       ],
+     needsTypeCheck = False
+     }),
+  ("t", emptyCommandInfo {
+     longname = "transaction",
+     syntax = "transaction (start|commit|rollback)",
+     synopsis = "Starts, commits or rollbacks a transaction",
+     explanation = unlines [
+       "If there is no active transaction, each create and drop command",
+       "starts its own transaction. Start it manually",
+       "if you want to perform several operations in one transaction.",
+       "This also makes batch operations a lot faster."
+       ],
+     flags = [],
+     needsTypeCheck = False
      })
   ]
  where
    needPGF exec opts ts = do
      mb_pgf <- getPGF
      case mb_pgf of
-       Just pgf -> liftSIO $ exec opts ts pgf
+       Just pgf -> do liftSIO $ exec opts ts pgf
        _ -> fail "Import a grammar before using this command"
 
    joinPiped (Piped (es1,ms1)) (Piped (es2,ms2)) = Piped (jA es1 es2,ms1+++-ms2)
@@ -717,13 +798,17 @@ pgfCommands = Map.fromList [
 
    linear :: [Option] -> Concr -> Expr -> [String]
    linear opts concr = case opts of
-       _ | isOpt "all"     opts -> concat .
-                                   map (map snd) . tabularLinearizeAll concr
-       _ | isOpt "list"    opts -> (:[]) . commaList . concat .
-                                   map (map snd) . tabularLinearizeAll concr
-       _ | isOpt "table"   opts -> concat .
-                                    map (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
+       _ | isOpt "list"    opts &&
+           isOpt "all"     opts -> map (commaList . map snd) . tabularLinearizeAll concr
+       _ | isOpt "list"    opts -> (:[]) . commaList .
+                                   map snd . tabularLinearize concr
+       _ | isOpt "table"   opts &&
+           isOpt "all"     opts -> map (\(p,v) -> p+++":"+++v) . concat . tabularLinearizeAll concr
+       _ | isOpt "table"   opts -> map (\(p,v) -> p+++":"+++v) . tabularLinearize concr
+       _ | isOpt "bracket" opts &&
+           isOpt "all"     opts -> map (unwords . map showBracketedString) . bracketedLinearizeAll concr
        _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
+       _ | isOpt "all"     opts -> linearizeAll concr
        _                        -> (:[]) . linearize concr
 
    -- replace each non-atomic constructor with mkC, where C is the val cat
@@ -749,8 +834,9 @@ pgfCommands = Map.fromList [
 
    optLangsFlag flag pgf opts =
      case valStrOpts flag "" opts of
-       ""  -> Map.elems langs
-       str -> mapMaybe (completeLang pgf) (chunks ',' str)
+       "no" -> []
+       ""   -> Map.elems langs
+       str  -> mapMaybe (completeLang pgf) (chunks ',' str)
      where
        langs = languages pgf
 
@@ -768,11 +854,15 @@ pgfCommands = Map.fromList [
                          Nothing -> error ("Can't parse '"++str++"' as a type")
      in maybeStrOpts "cat" (startCat pgf) readOpt opts
    optViewFormat opts = valStrOpts "format" "png" opts
-   optViewGraph opts = valStrOpts "view" "open" opts
+   optViewGraph opts = valStrOpts "view" open_cmd opts
    optNum opts = valIntOpts "number" 1 opts
    optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
    takeOptNum opts = take (optNumInf opts)
 
+   open_cmd | os == "linux"   = "xdg-open"
+            | os == "mingw32" = "start"
+            | otherwise       = "open"
+
    returnFromExprs show_p es =
      return $ 
        case es of
@@ -782,7 +872,7 @@ pgfCommands = Map.fromList [
    prGrammar pgf opts
      | isOpt "pgf"      opts = do
           let outfile = valStrOpts "file" (abstractName pgf ++ ".pgf") opts
-          restricted $ writePGF outfile pgf
+          restricted $ writePGF outfile pgf (Just (map concreteName (optLangs pgf opts)))
           putStrLn $ "wrote file " ++ outfile
           return void
      | isOpt "cats"     opts = return $ fromString $ unwords $ categories pgf
@@ -805,6 +895,17 @@ pgfCommands = Map.fromList [
    morphos pgf opts s =
      [(s,lookupMorpho concr s) | concr <- optLangs pgf opts]
 
+   morphoCohorts f concr s = f (lookupCohorts concr s)
+
+   morphoKnown = morphoClassify True
+
+   morphoMissing = morphoClassify False
+
+   morphoClassify k concr s =
+     [w | (_,w,ans,_) <- lookupCohorts concr s, k /= null ans, notLiteral w]
+     where
+       notLiteral w = not (all isDigit w)
+
    optClitics opts = case valStrOpts "clitics" "" opts of
      "" -> []
      cs -> map reverse $ chunks ',' cs
@@ -815,19 +916,9 @@ pgfCommands = Map.fromList [
 
    -- ps -f -g s returns g (f s)
    treeOps pgf opts s = foldr app s (reverse opts) where
-     app (OOpt  op)         | Just (Left  f) <- treeOp pgf op = f
-     app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f x
-     app _                                                    = id
-
-morphoMissing  :: Concr -> [String] -> [String]
-morphoMissing = morphoClassify False
-
-morphoKnown    :: Concr -> [String] -> [String]
-morphoKnown = morphoClassify True
-
-morphoClassify :: Bool -> Concr -> [String] -> [String]
-morphoClassify k concr ws = [w | w <- ws, k /= null (lookupMorpho concr w), notLiteral w] where
-  notLiteral w = not (all isDigit w)
+     app (OOpt  op)          | Just (Left  f) <- treeOp pgf op = f
+     app (OFlag op (LStr x)) | Just (Right f) <- treeOp pgf op = f x
+     app _                                                     = id
 
 treeOpOptions pgf = [(op,expl) | (op,(expl,Left  _)) <- allTreeOps pgf]
 treeOpFlags   pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
@@ -867,7 +958,10 @@ prAllWords concr =
   unwords [w | (w,_) <- fullFormLexicon concr]
 
 prMorphoAnalysis (w,lps) =
-  unlines (w:[l ++ " : " ++ p ++ show prob | (l,p,prob) <- lps])
+  unlines (w:[l ++ " : " ++ p ++ " " ++ show prob | (l,p,prob) <- lps])
+
+prCohortAnalysis (i,w,lps,j) =
+  unlines ((show i++"-"++show j++" "++w):[l ++ " : " ++ p ++ " " ++ show prob | (l,p,prob) <- lps])
 
 viewGraphviz :: String -> String -> String -> [String] -> SIO CommandOutput
 viewGraphviz view format name grphs = do

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/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,7 +8,6 @@ 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.Infra.Dependencies(depGraph)
 import GF.Infra.CheckM
 import GF.Text.Pretty(render,pp)
@@ -16,12 +16,11 @@ 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)
-import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
+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,14 +162,15 @@ sourceCommands = Map.fromList [
       do sgr <- getGrammar
          liftSIO (exec opts (toStrings ts) sgr)
 
-    compute_concrete opts ws sgr = fmap fst $ runCheck $
-      case runP pExp (UTF8.fromString s) of
-        Left (_,msg) -> return $ pipeMessage msg
-        Right t      -> do t <- checkComputeTerm opts sgr t
-                           return (fromString (showTerm sgr style q 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) =
@@ -183,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
@@ -199,24 +196,15 @@ sourceCommands = Map.fromList [
                 | otherwise = unwords $ map prTerm ops
           return $ fromString printed
 
-    show_operations os ts sgr = fmap fst $ runCheck $
-      case greatestResource sgr of
-        Nothing -> checkError (pp "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 <- 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
@@ -253,14 +241,20 @@ sourceCommands = Map.fromList [
          return void
 
 checkComputeTerm os sgr t =
-  do mo <- maybe (checkError (pp "no source grammar in scope")) return $
-           greatestResource sgr
+  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 sgr [] t                                
-     let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-     fmap evalStr (normalForm sgr 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/Compile.hs

@@ -1,42 +1,50 @@
 module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
 
+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,(<=<))
-import GF.System.Directory(doesFileExist,getModificationTime)
+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 PGF2(PGF,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
+
+    -- 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 gr abs probs
+    pgf <- grammar2PGF opts mb_pgf gr' abs probs
     when (verbAtLeast opts Normal) $ putStrE "OK"
     return pgf
 
@@ -48,28 +56,17 @@ 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 =
@@ -108,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

@@ -7,7 +7,6 @@ import GF.Infra.Option
 import GF.Compile.OptimizePGF
 
 import PGF2
-import PGF2.Internal
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map

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

@@ -27,9 +27,8 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
-import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
-import GF.Compile.Compute.Concrete(normalForm)
+import GF.Compile.TypeCheck.Concrete(checkLType,inferLType)
+import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef)
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -65,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)
@@ -173,26 +172,26 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
                 Just (L loc typ) -> chIn loc "linearization type of" $ do
-                                      (typ,_) <- checkLType gr [] typ typeType
-                                      typ  <- normalForm gr typ
+                                      (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
       update sm c (CncCat mty mdef mref mpr mpmcfg)
@@ -201,13 +200,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       mt <- case (mty,mt) of
               (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
       update sm c (CncFun mty mt mpr mpmcfg)
@@ -216,14 +215,14 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       (pty', pde') <- case (pty,pde) of
          (Just (L loct ty), Just (L locd de)) -> do
            ty'     <- chIn loct "operation" $ do
-                         (ty,_) <- checkLType gr [] ty typeType
-                         normalForm gr ty
+                         (ty,_) <- checkLType g ty typeType
+                         normalForm g ty
            (de',_) <- chIn locd "operation" $
-                         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" $
-                          inferLType gr [] de
+                          inferLType g de
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
@@ -231,39 +230,41 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
       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
+      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 <- mapM (uncurry $ flip (checkLType gr []))
-                  [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
+      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]
+      --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
-      (sm,cnt,ts) <- chIn loc "parameter type" $
-                        mkParamValues sm 0 [] pcs
+      (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 sm
  where
    gr = prependModule sgr sm
+   g = Gl gr (stdPredef g)
    chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
 
-   mkParamValues sm         cnt ts []          = return (sm,cnt,[])
-   mkParamValues sm@(mn,mi) cnt ts ((f,co):fs) = do
-     sm <- case lookupIdent f (jments mi) of
-             Ok (ResValue ty _) -> update sm f (ResValue ty cnt)
-             Bad msg            -> checkError (pp msg)
+   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) <- mkParamValues sm (cnt+length vs) ts fs
-     return (sm,cnt,map (mkApp (QC (mn,f))) vs ++ ts)
+     (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 ()
 
@@ -281,7 +282,19 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
        t' <- compAbsTyp ((x,Vr x):g) t
        return $ Prod b x a' t'
      Abs _ _ _ -> return t
-     _ -> composOp (compAbsTyp g) 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)})
 
@@ -289,7 +302,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
 -- | 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
@@ -299,22 +312,22 @@ linTypeOfType :: Grammar -> ModuleName -> L Type -> Check ([Ident],Ident,Context
 linTypeOfType cnc m (L loc typ) = do
   let (ctxt,res_cat) = typeSkeleton typ
   val <- lookLin res_cat
-  lin_args <- mapM mkLinArg (zip [0..] ctxt)
+  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),cat)
+     return ((Explicit,varX i,rec),cat)
    lookLin (_,c) = checks [ --- rather: update with defLinType ?
-      lookupLincat cnc m c >>= normalForm 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

@@ -33,7 +33,7 @@ convertFile conf src file = do
       (ex,   end) = break (=='"') (tail exend)
     in ((unwords (words cat),ex), tail end)  -- quotes ignored
   pgf = resource_pgf conf
-  lang = language conf 
+  lang = concrete conf
   convEx (cat,ex) = do
     appn "("
     let typ = maybe (error "no valid cat") id $ readType cat
@@ -61,7 +61,7 @@ convertFile conf src file = do
 data ExConfiguration = ExConf {
   resource_pgf :: PGF,
   verbose  :: Bool,
-  language :: Concr,
+  concrete :: Concr,
   printExp :: Expr -> String
   }
 

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

@@ -4,7 +4,6 @@ import PGF2
 import GF.Compile.PGFtoHaskell
 --import GF.Compile.PGFtoAbstract
 import GF.Compile.PGFtoJava
-import GF.Compile.PGFtoJSON
 import GF.Infra.Option
 --import GF.Speech.CFG
 import GF.Speech.PGFToCFG
@@ -35,7 +34,7 @@ exportPGF opts fmt pgf =
       FmtPGFPretty    -> multi "txt" (showPGF)
       FmtCanonicalGF  -> [] -- canon "gf" (render80 . abstract2canonical)
       FmtCanonicalJson-> []
-      FmtJSON         -> multi "json"  pgf2json
+      FmtSourceJson   -> []
       FmtHaskell      -> multi "hs"  (grammar2haskell opts name)
       FmtJava         -> multi "java" (grammar2java opts name)
       FmtBNF          -> single "bnf"   bnfPrinter
@@ -50,6 +49,7 @@ exportPGF opts fmt pgf =
       FmtSLF          -> single "slf"  slfPrinter
       FmtRegExp       -> single "rexp" regexpPrinter
       FmtFA           -> single "dot"  slfGraphvizPrinter
+      FmtLR           -> single "dot"  (\_ -> graphvizLRAutomaton)
  where
    name = fromMaybe (abstractName pgf) (flag optName opts)
 
@@ -60,4 +60,3 @@ exportPGF opts fmt pgf =
 
    single :: String -> (PGF -> Concr -> String) -> [(FilePath,String)]
    single ext pr = [(concreteName cnc <.> ext, pr pgf cnc) | cnc <- Map.elems (languages pgf)]
-

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

@@ -5,7 +5,7 @@ import GF.Grammar
 import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
 import GF.Data.Operations
 import PGF2(Literal(..))
-import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..))
+import PGF2.ByteCode
 import qualified Data.Map as Map
 import Data.List(nub,mapAccumL)
 import Data.Maybe(fromMaybe)
@@ -19,9 +19,7 @@ generateByteCode gr arity eqs =
       b = if arity == 0 || null eqs
             then instrs
             else CHECK_ARGS arity:instrs
-  in case bs of
-       [[FAIL]] -> []         -- in the runtime this is a more efficient variant of [[FAIL]]
-       _        -> reverse bs
+  in reverse bs
   where
     is = push_is (arity-1) arity []
 

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

@@ -0,0 +1,364 @@
+{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Krasimir Angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Convert PGF grammar to PMCFG grammar.
+--
+-----------------------------------------------------------------------------
+
+module GF.Compile.GeneratePMCFG
+    (generatePMCFG, pmcfgForm, type2fields
+    ) where
+
+import GF.Grammar hiding (VApp,VRecType)
+import GF.Grammar.Predef
+import GF.Grammar.Lookup
+import GF.Infra.CheckM
+import GF.Infra.Option
+import GF.Text.Pretty
+import GF.Compile.Compute.Concrete
+import GF.Data.Operations(Err(..))
+import PGF2.Transactions
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.ST
+import qualified Data.Map.Strict as Map
+import qualified Data.Sequence as Seq
+import Data.List(mapAccumL,sortOn,sortBy)
+import Data.Maybe(fromMaybe,isNothing)
+import Data.STRef
+
+generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
+generatePMCFG opts cwd gr cmo@(cm,cmi)
+  | mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) =
+                do let gr' = prependModule gr cmo
+                   (js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty
+                   return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)})
+  | otherwise = return cmo
+  where
+    mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m)))
+
+type SequenceSet = Map.Map [Symbol] Int
+
+addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do
+  (defs,seqs) <-
+          case mdef of
+            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+                                   term <- mkLinDefault gr ty
+                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do
+                                   pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs
+  (refs,seqs) <- 
+          case mref of
+            Nothing           -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                   term <- mkLinReference gr ty
+                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
+            Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do
+                                   pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs
+  mprn  <- case mprn of
+             Nothing          -> return Nothing
+             Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
+                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   return (Just (L loc prn))
+  return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs)
+addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do
+  (rules,seqs) <-
+           checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
+             pmcfgForm gr term ctxt val seqs
+  mprn  <- case mprn of
+             Nothing          -> return Nothing
+             Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
+                                   prn <- normalForm (Gl gr stdPredef) prn
+                                   return (Just (L loc prn))
+  return (CncFun mty mlin mprn (Just rules),seqs)
+addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
+
+pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
+pmcfgForm gr t ctxt ty seqs = do
+  res <- runEvalM (Gl gr stdPredef) $ do
+           (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
+                                          t <- EvalM (\(Gl gr _) k e mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
+                                                                                       k t mt d r msgs)
+                                          tnk <- newThunk [] t
+                                          return (arg_no+1,tnk))
+                                      0 ctxt
+           v <- eval [] t args
+           (lins,params) <- flatten v ty ([],[])
+           lins <- fmap reverse $ mapM str2lin lins
+           (r,rs,_) <- compute params
+           args <- zipWithM tnk2lparam args ctxt
+           vars <- getVariables
+           let res = LParam r (order rs)
+           return (vars,args,res,lins)
+  return (runState (mapM mkProduction res) seqs)
+  where
+    tnk2lparam tnk (_,_,ty) = do
+      v <- force tnk
+      (_,params) <- flatten v ty ([],[])
+      (r,rs,_) <- compute params
+      return (PArg [] (LParam r (order rs)))
+
+    compute []              = return (0,[],1)
+    compute ((v,ty):params) = do
+      (r, rs ,cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute params
+      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+
+    mkProduction (vars,args,res,lins) = do
+      lins <- mapM getSeqId lins
+      return (Production vars args res lins)
+      where
+        getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId
+        getSeqId lin = state $ \m ->
+          case Map.lookup lin m of
+            Just seqid -> (seqid,m)
+            Nothing    -> let seqid = Map.size m
+                          in (seqid,Map.insert lin seqid m)
+
+type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
+type2metaTerm gr d ms r rs (Sort s) | s == cStr =
+  return (ms,r+1,TSymCat d r rs)
+type2metaTerm gr d ms r rs (RecType lbls) = do
+  ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
+                                                        LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
+                                                        lbl    -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
+                                                                     return ((ms',r'),(lbl,(Just ty,t))))
+                                 (ms,r) lbls
+  return (ms',r',R ass)
+type2metaTerm gr d ms r rs (Table p q)
+  | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
+                    return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
+  | null (collectParams q)
+               = do let pv    = varX (length rs+1)
+                    (ms',delta,t) <-
+                        fixST $ \(~(_,delta,_)) ->
+                                     do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
+                                        return (ms',r'-r,t)
+                    return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
+  | otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q
+                                                               return ((ms',r'),t))
+                                              (ms,r) [0..count-1]
+                   return (ms',r+(r'-r),V p ts)
+  where
+    collectParams (QC q)      = [q]
+    collectParams (Table _ t) = collectParams t
+    collectParams t           = collectOp collectParams t
+
+    count = case allParamValues gr p of
+              Ok ts   -> length ts
+              Bad msg -> error msg
+type2metaTerm gr d ms r rs ty@(QC q) = do
+  let i = Map.size ms + 1
+  tnk <- newSTRef (Narrowing i ty)
+  return (Map.insert i tnk ms,r,Meta i)
+type2metaTerm gr d ms r rs ty
+  | Just n <- isTypeInts ty = do
+      let i = Map.size ms + 1
+      tnk <- newSTRef (Narrowing i ty)
+      return (Map.insert i tnk ms,r,Meta i)
+
+flatten (VR as) (RecType lbls) st = do
+  foldM collect st lbls
+  where
+    collect st (lbl,ty) =
+      case lookup lbl as of
+        Just tnk -> do v <- force tnk
+                       flatten v ty st
+        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
+flatten v@(VT _ env cs) (Table p q) st = do
+  ts <- getAllParamValues p
+  foldM collect st ts
+  where
+    collect st t = do
+      tnk <- newThunk [] t
+      let v0 = VS v tnk []
+      v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs)
+      flatten v q st
+flatten (VV _ tnks) (Table _ q) st = do
+  foldM collect st tnks
+  where
+    collect st tnk = do
+      v <- force tnk
+      flatten v q st
+flatten v (Sort s) (lins,params) | s == cStr = do
+  deepForce v
+  return (v:lins,params)
+flatten v ty@(QC q) (lins,params) = do
+  deepForce v
+  return (lins,(v,ty):params)
+flatten v ty (lins,params)
+  | Just n <- isTypeInts ty = do deepForce v
+                                 return (lins,(v,ty):params)
+  | otherwise               = evalError (pp (showValue v))
+
+deepForce (VR as)          = mapM_ (\(lbl,v) -> force v >>= deepForce) as
+deepForce (VApp q tnks)    = mapM_ (\tnk -> force tnk >>= deepForce) tnks
+deepForce (VC v1 v2)       = deepForce v1 >> deepForce v2
+deepForce (VAlts def alts) = do deepForce def
+                                mapM_ (\(v,_) -> deepForce v) alts
+deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs
+deepForce _                = return ()
+
+str2lin (VApp q [])
+  | q == (cPredef, cBIND)       = return [SymBIND]
+  | q == (cPredef, cNonExist)   = return [SymNE]
+  | q == (cPredef, cSOFT_BIND)  = return [SymSOFT_BIND]
+  | q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
+  | q == (cPredef, cCAPIT)      = return [SymCAPIT]
+  | q == (cPredef, cALL_CAPIT)  = return [SymALL_CAPIT]
+str2lin (VStr s)         = return [SymKS s]
+str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
+                              return [SymCat d (LParam r (order rs))]
+  where
+    compute r' []                     = return (r',[])
+    compute r' ((cnt',(tnk,ty)):tnks) = do
+      v <- force tnk
+      (r, rs, cnt) <- param2int v ty
+      (r',rs') <- compute r' tnks
+      return (r*cnt'+r',combine cnt' rs rs')
+str2lin (VSymVar d r)    = return [SymVar d r]
+str2lin VEmpty           = return []
+str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
+str2lin v0@(VAlts def alts)
+                         = do def <- str2lin def
+                              alts <- forM alts $ \(v1,v2) -> do
+                                lin <- str2lin v1
+                                ss  <- to_strs v2
+                                return (lin,ss)
+                              return [SymKP def alts]
+  where
+    to_strs (VStrs vs)    = mapM to_str vs
+    to_strs (VPatt _ _ p) = from_patt p
+    to_strs v             = fail
+
+    to_str (VStr s) = return s
+    to_str _        = fail
+
+    from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
+    from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
+    from_patt (PString s)  = return [s]
+    from_patt (PChars cs)  = return (map (:[]) cs)
+    from_patt _            = fail
+
+    fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
+str2lin v                = do t <- value2term False [] v
+                              evalError ("the string:" <+> ppTerm Unqualified 0 t $$
+                                         "cannot be evaluated at compile time.")
+
+param2int (VR as) (RecType lbls) = compute lbls
+  where
+    compute []              = return (0,[],1)
+    compute ((lbl,ty):lbls) = do
+      case lookup lbl as of
+        Just tnk -> do v <- force tnk
+                       (r, rs ,cnt ) <- param2int v ty
+                       (r',rs',cnt') <- compute lbls
+                       return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+        Nothing  -> evalError ("Missing value for label" <+> pp lbl $$
+                               "among" <+> hsep (punctuate (pp ',') (map fst as)))
+param2int (VApp q tnks) ty = do
+  (r ,    ctxt,cnt ) <- getIdxCnt q
+  (r',rs',     cnt') <- compute ctxt tnks
+  return (r+r',rs',cnt)
+  where
+    getIdxCnt q = do
+      (_,ResValue (L _ ty) idx) <- getInfo q
+      let (ctxt,QC p) = typeFormCnc ty
+      (_,ResParam _ (Just (_,cnt))) <- getInfo p
+      return (idx,ctxt,cnt)
+
+    compute []              []         = return (0,[],1)
+    compute ((_,_,ty):ctxt) (tnk:tnks) = do
+      v <- force tnk
+      (r, rs ,cnt ) <- param2int v ty
+      (r',rs',cnt') <- compute ctxt tnks
+      return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt')
+param2int (VInt n)        ty
+  | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1)
+param2int (VMeta tnk _) ty = do
+  tnk_st <- getRef tnk
+  case tnk_st of
+    Evaluated _ v  -> param2int v ty
+    Narrowing j ty -> do ts <- getAllParamValues ty
+                         return (0,[(1,j-1)],length ts)
+param2int v ty = do t <- value2term True [] v
+                    evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
+                               "cannot be evaluated at compile time.")
+
+combine' 1   rs 1    rs' = []
+combine' 1   rs cnt' rs' = rs'
+combine' cnt rs 1    rs' = rs
+combine' cnt rs cnt' rs' = combine cnt' rs rs'
+
+combine cnt'          []            rs' = rs'
+combine cnt'          rs             [] = [(r*cnt',pv) | (r,pv) <- rs]
+combine cnt' ((r,pv):rs) ((r',pv'):rs') =
+  case compare pv pv' of
+    LT -> (r*cnt',   pv ) : combine cnt' rs ((r',pv'):rs')
+    EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
+    GT -> (       r',pv') : combine cnt' ((r,pv):rs) rs'
+
+order = sortBy (\(r1,_) (r2,_) -> compare r2 r1)
+
+mapAccumM f a []     = return (a,[])
+mapAccumM f a (x:xs) = do (a, y) <- f a x
+                          (a,ys) <- mapAccumM f a xs
+                          return (a,y:ys)
+
+type2fields :: SourceGrammar -> Type -> [String]
+type2fields gr = type2fields empty
+  where
+    type2fields d (Sort s) | s == cStr = [show d]
+    type2fields d (RecType lbls) =
+      concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) lbls
+    type2fields d (Table p q) =
+      let Ok ts = allParamValues gr p
+      in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts
+    type2fields d _ = []
+
+mkLinDefault :: SourceGrammar -> Type -> Check Term
+mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
+ where
+   mkDefField ty =
+     case ty of
+       Table p t  -> do t' <- mkDefField t
+                        let T _ cs = mkWildCases t'
+                        return $ T (TWild p) cs
+       Sort s | s == cStr -> return (Vr varStr)
+       QC p       -> case lookupParamValues gr p of
+                       Ok []    -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p)
+                       Ok (v:_) -> return v
+                       Bad msg  -> fail msg
+       RecType r -> do
+         let (ls,ts) = unzip r
+         ts <- mapM mkDefField ts
+         return $ R (zipWith assign ls ts)
+       _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val
+       _ -> checkError ("a field in a linearization type cannot be" <+> ty)
+
+mkLinReference :: SourceGrammar -> Type -> Check Term
+mkLinReference gr typ = do
+  mb_term <- mkRefField typ (Vr varStr)
+  return (Abs Explicit varStr (fromMaybe Empty mb_term))
+  where
+    mkRefField ty trm =
+      case ty of
+        Table pty ty -> case allParamValues gr pty of
+                          Ok []     -> checkError ("no parameter values given to type" <+> pty)
+                          Ok (p:ps) -> mkRefField ty (S trm p)
+                          Bad msg   -> fail msg
+        Sort s | s == cStr -> return (Just trm)
+        QC p       -> return Nothing
+        RecType rs -> traverse rs trm
+        _ | Just _ <- isTypeInts ty -> return Nothing
+        _ -> checkError ("a field in a linearization type cannot be" <+> typ)
+
+    traverse []          trm = return Nothing
+    traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l)
+                                  case res of
+                                    Just trm -> return (Just trm)
+                                    Nothing  -> traverse rs trm

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

@@ -0,0 +1,128 @@
+-- | Translate grammars to Canonical form
+-- (a common intermediate representation to simplify export to other formats)
+module GF.Compile.GrammarToCanonical(
+       grammar2canonical
+       ) where
+
+import GF.Data.ErrM
+import GF.Grammar
+import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
+import GF.Infra.Option(Options,noOptions)
+import GF.Infra.CheckM
+import GF.Compile.Compute.Concrete2
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Maybe(mapMaybe,fromMaybe)
+import Control.Monad (forM)
+
+-- | Generate Canonical code for the named abstract syntax and all associated
+-- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> Grammar -> Check Grammar
+grammar2canonical opts absname gr = do
+  abs <- abstract2canonical absname gr
+  cncs <- concretes2canonical opts absname gr
+  return (mGrammar (abs:cncs))
+
+-- | Generate Canonical code for the named abstract syntax
+abstract2canonical :: ModuleName -> Grammar -> Check Module
+abstract2canonical absname gr = do
+  let infos = [(id,info) | ((mn,id),info) <- allOrigInfos gr absname]
+  return (absname, ModInfo {
+                     mtype   = MTAbstract,
+                     mstatus = MSComplete,
+                     mflags  = convFlags gr absname,
+                     mextend = [],
+                     mwith   = Nothing,
+                     mopens  = [],
+                     mexdeps = [],
+                     msrc    = "",
+                     mseqs   = Nothing,
+                     jments  = Map.fromList infos
+                   })
+
+-- | Generate Canonical code for the all concrete syntaxes associated with
+-- the named abstract syntax in given the grammar.
+concretes2canonical :: Options -> ModuleName -> Grammar -> Check [Module]
+concretes2canonical opts absname gr = do
+  res <- sequence
+           [concrete2canonical gr absname cnc modinfo
+               | cnc<-allConcretes gr absname,
+                 let Ok modinfo = lookupModule gr cnc]
+  let pts = Set.unions (map fst res)
+  ms <- closure pts (Set.toList pts) (Map.fromList (map snd res))
+  return (Map.toList ms)
+  where
+    closure pts []            ms = return ms
+    closure pts (q@(m,id):qs) ms = do
+      (_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q
+      let pts'    = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx]
+          new_pts = Set.difference pts' pts
+      closure (Set.union new_pts pts) (Set.toList new_pts++qs) (insert q info ms)
+
+    insert (m,id) info ms =
+      let mi0 = fromMaybe emptyRes (Map.lookup m ms)
+          mi  = mi0{jments=Map.insert id info (jments mi0)}
+      in Map.insert m mi ms
+
+    emptyRes =
+      ModInfo {
+        mtype   = MTResource,
+        mstatus = MSComplete,
+        mflags  = noOptions,
+        mextend = [],
+        mwith   = Nothing,
+        mopens  = [],
+        mexdeps = [],
+        msrc    = "",
+        mseqs   = Nothing,
+        jments  = Map.empty
+      }
+
+type QSet = Set.Set (ModuleName,Ident)
+
+-- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check (QSet,Module)
+concrete2canonical gr absname cncname modinfo = do
+  let g = Gl gr (stdPredef g)
+  infos <- mapM (convInfo g) (allOrigInfos gr cncname)
+  let pts = Set.unions (map fst infos)
+  return (pts,
+          (cncname, ModInfo {
+                      mtype   = MTConcrete absname,
+                      mstatus = MSComplete,
+                      mflags  = convFlags gr cncname,
+                      mextend = [],
+                      mwith   = Nothing,
+                      mopens  = [],
+                      mexdeps = [],
+                      msrc    = "",
+                      mseqs   = Nothing,
+                      jments  = Map.fromList (mapMaybe snd infos)
+                    }))
+  where
+    convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
+      typ <- normalForm g typ
+      let pts = paramTypes typ
+      return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
+    convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
+      def <- normalForm g (eta_expand def ctx)
+      return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
+    convInfo g  _ = return (Set.empty,Nothing)
+
+    eta_expand t []                   = t
+    eta_expand t ((Implicit,x,_):ctx) = Abs Implicit x (eta_expand (App t (ImplArg (Vr x))) ctx)
+    eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x))           ctx)
+
+
+paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
+paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
+paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
+paramTypes (Sort _) = Set.empty
+paramTypes (EInt _) = Set.empty
+paramTypes (QC q) = Set.singleton q
+paramTypes (FV ts) = Set.unions (map paramTypes ts)
+paramTypes _ = Set.empty
+
+
+convFlags :: Grammar -> ModuleName -> Options
+convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn)

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

@@ -18,135 +18,126 @@ import GF.Infra.Option
 import GF.Infra.UseIO (IOE)
 import GF.Data.Operations
 
+import Control.Monad(forM_,foldM)
 import Data.List
 import Data.Char
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
+import qualified Data.Sequence as Seq
 import Data.Array.IArray
 import Data.Maybe(fromMaybe)
 import System.FilePath
 import System.Directory
 
-import GHC.Prim
-import GHC.Base(getTag)
+grammar2PGF :: Options -> Maybe PGF -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
+grammar2PGF opts mb_pgf gr am probs = do
+  let abs_name = mi2i am
+  pgf <- case mb_pgf of
+           Just pgf | abstractName pgf == abs_name   ->
+                         do return pgf
+           _        | snd (flag optLinkTargets opts) ->
+                         do let fname = maybe id (</>)
+                                              (flag optOutputDir opts)
+                                              (fromMaybe abs_name (flag optName opts)<.>"ngf")
+                            exists <- doesFileExist fname
+                            if exists
+                              then removeFile fname
+                              else return ()
+                            putStr ("(Boot image "++fname++") ")
+                            newNGF abs_name (Just fname) 0
+                    | otherwise ->
+                         do newNGF abs_name Nothing 0
 
-grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
-grammar2PGF opts gr am probs = do
-  gr <- mkAbstr am probs
-  return gr {-do
-  cnc_infos <- getConcreteInfos gr am
-  return $
-    build (let gflags   = if flag optSplitPGF opts 
-                            then [("split", LStr "true")]
-                            else []
-               (an,abs) = mkAbstr am probs
-               cncs     = map (mkConcr opts abs) cnc_infos
-           in newPGF gflags an abs cncs)-}
+  pgf <- modifyPGF pgf $ do
+    sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
+    sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
+    sequence_ [createFunction f ty arity bcode p | (f,ty,arity,bcode,p) <- funs]
+    forM_ (allConcretes gr am) $ \cm ->
+      createConcrete (mi2i cm) $ do
+        let cflags = err (const noOptions) mflags (lookupModule gr cm)
+        sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
+        let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]]
+                    , let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0]
+                          prods   = ([id_prod],[id_prod])
+                      in [(cInt,   CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods))
+                         ]
+                    )
+                    : prepareSeqTbls (Look.allOrigInfos gr cm)
+        infos <- processInfos createCncCats infos
+        infos <- processInfos createCncFuns infos
+        return ()
+  return pgf
   where
     aflags = err (const noOptions) mflags (lookupModule gr am)
 
-    mkAbstr :: ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
-    mkAbstr am probs = do
-      let abs_name = mi2i am
-      mb_ngf_path <-
-         if snd (flag optLinkTargets opts)
-           then do let fname = maybe id (</>)
-                                     (flag optOutputDir opts)
-                                     (fromMaybe abs_name (flag optName opts)<.>"ngf")
-                   exists <- doesFileExist fname
-                   if exists
-                     then removeFile fname
-                     else return ()
-                   putStr ("(Boot image "++fname++") ")
-                   return (Just fname)
-           else do return Nothing
-      gr <- newNGF abs_name mb_ngf_path
-      modifyPGF gr $ do
-        sequence_ [setAbstractFlag name value | (name,value) <- flags]
-        sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
-        sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs]
+    adefs =
+        [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
+        Look.allOrigInfos gr am
+
+    toLogProb = realToFrac . negate . log
+
+    cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
+                               ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
+
+    funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
+                               ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
+                               let arity = mkArity ma mdef ty,
+                               let bcode = mkDef gr arity mdef,
+                               let f' = i2i f]
+                               
+    funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
+                    [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
+                                                               let (_,(_,cat),_) = GM.typeForm ty,
+                                                               let f' = i2i f]
       where
-        adefs =
-            [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
-            Look.allOrigInfos gr am
-
-        flags = optionsPGF aflags
-
-        toLogProb = realToFrac . negate . log
-
-        cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
-                                   ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c]
-
-        funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) |
-                                   ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs,
-                                   let arity = mkArity ma mdef ty,
-                                   let bcode = mkDef gr arity mdef,
-                                   let f' = i2i f]
-                                   
-        funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++))
-                        [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs,
-                                                                   let (_,(_,cat),_) = GM.typeForm ty,
-                                                                   let f' = i2i f]
+        pad :: [(a,Maybe Double)] -> [(a,Double)]
+        pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
           where
-            pad :: [(a,Maybe Double)] -> [(a,Double)]
-            pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs]
-              where
-                deflt = case length [f | (f,Nothing) <- pfs] of
-                          0 -> 0
-                          n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
-{-
-    mkConcr opts abs (cm,ex_seqs,cdefs) =
-      let cflags = err (const noOptions) mflags (lookupModule gr cm)
-          ciCmp | flag optCaseSensitive cflags = compare
-                | otherwise                    = compareCaseInsensitive
+            deflt = case length [f | (f,Nothing) <- pfs] of
+                      0 -> 0
+                      n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
 
-          flags = optionsPGF aflags
+    prepareSeqTbls infos = 
+       (map addSeqTable . Map.toList . Map.fromListWith (++))
+               [(m,[(c,info)]) | ((m,c),info) <- infos]
+       where
+         addSeqTable (m,infos) = 
+           case lookupModule gr m of
+             Ok mi   -> case mseqs mi of
+                          Just seqs -> (fmap Left seqs,infos)
+                          Nothing   -> (Seq.empty,[])
+             Bad msg -> error msg
 
-          seqs = (mkSetArray . Set.fromList . concat) $
-                       (elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
+    processInfos f []                    = return []
+    processInfos f ((seqtbl,infos):rest) = do
+      seqtbl <- foldM f seqtbl infos
+      rest <- processInfos f rest
+      return ((seqtbl,infos):rest)
 
-          !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
-          cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
-          !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
-                                = genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt1 cnccat_ranges
+    createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do
+      seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl
+      case mprn of
+        Nothing        -> return ()
+        Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn))
+      return seqtbl
+    createCncCats seqtbl _ = return seqtbl
 
-          printnames = genPrintNames cdefs
+    createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do
+      seqtbl <- createLin (i2i f) prods seqtbl
+      case mprn of
+        Nothing        -> return ()
+        Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
+      return seqtbl
+    createCncFuns seqtbl _ = return seqtbl
 
-          startCat = (fromMaybe "S" (flag optStartCat aflags))
+    term2tokens (K tok)     = [tok]
+    term2tokens (C t1 t2)   = term2tokens t1 ++ term2tokens t2
+    term2tokens (Typed t _) = term2tokens t
+    term2tokens _           = []
 
-          (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
-               (if flag optOptimizePGF opts then optimizePGF startCat else id)
-                    (lindefs,linrefs,productions,cncfuns,elems seqs,cnccats)
-
-      in (mi2i cm, newConcr abs
-                            flags
-                            printnames
-                            lindefs'
-                            linrefs'
-                            productions'
-                            cncfuns'
-                            sequences'
-                            cnccats'
-                            fid_cnt2)
-
-    getConcreteInfos gr am = mapM flatten (allConcretes gr am)
-      where
-        flatten cm = do
-          (seqs,infos) <- addMissingPMCFGs cm Map.empty
-                                           (lit_infos ++ Look.allOrigInfos gr cm)
-          return (cm,mkMapArray seqs :: Array SeqId [Symbol],infos)
-
-        lit_infos = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]]
-
-        -- if some module was compiled with -no-pmcfg, then
-        -- we have to create the PMCFG code just before linking
-        addMissingPMCFGs cm seqs []                  = return (seqs,[])
-        addMissingPMCFGs cm seqs (((m,id), info):is) = do
-          (seqs,info)  <- addPMCFG opts gr cenv Nothing am cm seqs id info
-          (seqs,infos) <- addMissingPMCFGs cm seqs is
-          return (seqs, ((m,id), info) : infos)
--}
 i2i :: Ident -> String
 i2i = showIdent
 

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

@@ -17,7 +17,6 @@
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
 import PGF2
-import PGF2.Internal
 
 import GF.Data.Operations
 import GF.Infra.Option
@@ -40,7 +39,6 @@ grammar2haskell opts name gr = foldr (++++) [] $
     where gr' = hSkeleton gr
           gadt = haskellOption opts HaskellGADT
           dataExt = haskellOption opts HaskellData
-          pgf2 = haskellOption opts HaskellPGF2
           lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
           gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
               | otherwise = ("G"++) . rmForbiddenChars
@@ -55,8 +53,7 @@ grammar2haskell opts name gr = foldr (++++) [] $
           extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
                        | dataExt = ["import Data.Data"]
                        | otherwise = []
-          pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
-                     | otherwise = ["import PGF hiding (Tree)"]
+          pgfImports = ["import PGF2", ""]
           types | gadt = datatypesGADT gId lexical gr'
                 | otherwise = datatypes gId derivingClause lexical gr'
           compos | gadt = prCompos gId lexical gr' ++ composClass
@@ -79,7 +76,7 @@ haskPreamble gadt name derivingClause imports =
   "",
   predefInst gadt derivingClause "GString" "String"  "unStr"    "mkStr",
   "",
-  predefInst gadt derivingClause "GInt"    "Int"     "unInt"    "mkInt",
+  predefInst gadt derivingClause "GInt"    "Integer"     "unInt"    "mkInt",
   "",
   predefInst gadt derivingClause "GFloat"  "Double"  "unFloat"  "mkFloat",
   "",
@@ -235,14 +232,14 @@ hInstance gId lexical m (cat,rules)
  | otherwise =
   "instance Gf" +++ gId cat +++ "where\n" ++
   unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
-            ++ if lexical cat then ["  gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else [])
+            ++ if lexical cat then ["  gf (" ++ lexicalConstructor cat +++ "x) = mkApp x []"] else [])
  where
    ec = elemCat cat
    baseVars = mkVars (baseSize (cat,rules))
    mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
      (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
      "=" +++ mkRHS f xx'
-   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
+   mkRHS f vars = "mkApp \"" ++ f ++ "\"" +++
        "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
 
 mkVars :: Int -> [String]
@@ -266,7 +263,7 @@ fInstance gId lexical m (cat,rules) =
     mkInst f xx =
      "      Just (i," ++
      "[" ++ prTList "," xx' ++ "])" +++
-     "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
+     "| i == \"" ++ f ++ "\" ->" +++ mkRHS f xx'
        where
          xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
          mkRHS f vars

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

@@ -50,7 +50,7 @@ import System.FilePath
 import GF.Text.Pretty
 
 type ModName = String
-type ModEnv  = Map.Map ModName (UTCTime,[ModName])
+type ModEnv  = Map.Map ModName (FilePath,UTCTime,[ModName])
 
 
 -- | Returns a list of all files to be compiled in topological order i.e.
@@ -98,14 +98,17 @@ getAllFiles opts ps env file = do
     -- returns 'ModuleInfo'. It fails if there is no such module
   --findModule :: ModName -> IOE ModuleInfo
     findModule name = do
-      (file,gfTime,gfoTime) <- findFile gfoDir ps name
+      (file,gfTime,gfoTime) <- findFile gfoDir ps env name
 
       let mb_envmod = Map.lookup name env
-          (st,t) = selectFormat opts (fmap fst mb_envmod) gfTime gfoTime
+          (st,t) = selectFormat opts (fmap snd3 mb_envmod) gfTime gfoTime
+
+          snd3 (_,y,_) = y
+          thd3 (_,_,z) = z
 
       (st,(mname,imps)) <-
           case st of
-            CSEnv  -> return (st, (name, maybe [] snd mb_envmod))
+            CSEnv  -> return (st, (name, maybe [] thd3 mb_envmod))
             CSRead -> do let gfo = if isGFO file then file else gf2gfo opts file
                          t_imps <- gfoImports gfo
                          case t_imps of
@@ -121,8 +124,8 @@ getAllFiles opts ps env file = do
       return (name,st,t,isJust gfTime,imps,dropFileName file)
 --------------------------------------------------------------------------------
 
-findFile gfoDir ps name =
-    maybe noSource haveSource =<< getFilePath ps (gfFile name)
+findFile gfoDir ps env name =
+  maybe noSource haveSource =<< getFilePath ps (gfFile name)
   where
     haveSource gfFile =
       do gfTime  <- getModificationTime gfFile
@@ -130,7 +133,7 @@ findFile gfoDir ps name =
          return (gfFile, Just gfTime, mb_gfoTime)
 
     noSource =
-        maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name)
+      maybe noGFO haveGFO =<< getFilePath gfoPath (gfoFile name)
       where
         gfoPath = maybe id (:) gfoDir ps
 
@@ -138,8 +141,11 @@ findFile gfoDir ps name =
           do gfoTime <- getModificationTime gfoFile
              return (gfoFile, Nothing, Just gfoTime)
 
-        noGFO = raise (render ("File" <+> gfFile name <+> "does not exist." $$
-                               "searched in:" <+> vcat ps))
+        noGFO =
+          case Map.lookup name env of
+            Just (fpath,t,_) -> return (fpath, Nothing, Nothing)
+            Nothing          -> raise (render ("File" <+> gfFile name <+> "does not exist." $$
+                                       "searched in:" <+> vcat ps <+> (show (env :: Map.Map ModName (FilePath,UTCTime,[ModName])))))
 
 gfImports opts file = importsOfModule `fmap` parseModHeader opts file
 

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

@@ -36,6 +36,7 @@ import GF.Grammar.Lookup
 import GF.Grammar.Macros
 import GF.Grammar.Printer
 import GF.Data.Operations
+import PGF2(abstractName,functionType,categoryContext)
 
 import Control.Monad
 import Data.List (nub,(\\))
@@ -58,10 +59,7 @@ renameModule cwd gr mo@(m,mi) = do
   return (m, mi{jments = js})
 
 type Status = (StatusMap, [(OpenSpec, StatusMap)])
-
-type StatusMap = Map.Map Ident StatusInfo
-
-type StatusInfo = Ident -> Term
+type StatusMap = Ident -> Maybe Term
 
 -- Delays errors, allowing many errors to be detected and reported
 renameIdentTerm env = accumulateError (renameIdentTerm' env)
@@ -74,14 +72,12 @@ renameIdentTerm' env@(act,imps) t0 =
     Cn c -> ident (\_ s -> checkError s) c
     Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
     Q (m',c) -> do
-      m <- lookupErr m' qualifs
-      f <- lookupIdent c m
-      return $ f c
+      f <- lookupErr m' qualifs
+      maybe (notFound c) return (f c)
     QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
     QC (m',c) -> do
-      m <- lookupErr m' qualifs
-      f <- lookupIdent c m
-      return $ f c
+      f <- lookupErr m' qualifs
+      maybe (notFound c) return (f c)
     _ -> return t0
   where
     opens   = [st  | (OSimple _,st) <- imps]
@@ -95,67 +91,68 @@ renameIdentTerm' env@(act,imps) t0 =
       | otherwise     = checkError s
 
     ident alt c =
-      case Map.lookup c act of
-        Just f -> return (f c)
-        _      -> case mapMaybe (Map.lookup c) opens of
-                    [f]  -> return (f c)
+      case act c of
+        Just t -> return t
+        _      -> case mapMaybe (\f -> f c) opens of
+                    [t]  -> return t
                     []   -> alt c ("constant not found:" <+> c $$
                                    "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                    fs   -> case nub [f c | f <- fs]  of
-                              [tr]     -> return tr
+                    ts   -> case nub ts  of
+                              [t]      -> return t
                               ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
                                                         "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
                                                         "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                                             return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
-       where
-        -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
-        -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
-        notFromCommonModule :: Term -> Bool
-        notFromCommonModule term =
-          let t = render $ ppTerm Qualified 0 term :: String
-           in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
-                        ["CommonX", "ConstructX", "ExtendFunctor"
-                        ,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
+                                             return t
 
-        -- If one of the terms comes from the common modules,
-        -- we choose the other one, because that's defined in the grammar.
-        bestTerm :: [Term] -> Term
-        bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
-        bestTerm ts@(t:_) =
-          let notCommon = [t | t <- ts, notFromCommonModule t]
-           in case notCommon of
-                []    -> t -- All terms are from common modules, return first of original list
-                (u:_) -> u -- ≥1 terms are not from common modules, return first of those
-
-info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
+info2status :: Maybe ModuleName -> Ident -> Info -> Term
 info2status mq c i = case i of
-  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
-  ResValue _ _ -> maybe Con (curry QC) mq
-  ResParam _ _ -> maybe Con (curry QC) mq
-  AnyInd True m -> maybe Con (const (curry QC m)) mq
-  AnyInd False m -> maybe Cn (const (curry Q m)) mq
-  _           -> maybe Cn (curry Q) mq
+  AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq c
+  ResValue _ _ -> maybe Con (curry QC) mq c
+  ResParam _ _ -> maybe Con (curry QC) mq c
+  AnyInd True m -> maybe Con (const (curry QC m)) mq c
+  AnyInd False m -> maybe Cn (const (curry Q m)) mq c
+  _           -> maybe Cn (curry Q) mq c
 
 tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap
-tree2status o = case o of
-  OSimple i   -> Map.mapWithKey (info2status (Just i))
-  OQualif i j -> Map.mapWithKey (info2status (Just j))
+tree2status o map = case o of
+  OSimple i   -> flip Map.lookup (Map.mapWithKey (info2status (Just i)) map)
+  OQualif i j -> flip Map.lookup (Map.mapWithKey (info2status (Just j)) map)
 
 buildStatus :: FilePath -> Grammar -> Module -> Check Status
 buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
   let gr1  = prependModule gr mo
-      exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m]
-  ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
-  let sts = map modInfo2status (exts++ops)
+      exts = [(o,modInfo2status o mi) | (m,mi) <- allExtends gr1 m, let o = OSimple m]
+  ops <- mapM (openSpec2status gr1) (mopens mi)
+  let sts = exts++ops
   return (if isModCnc mi
-            then (Map.empty,       reverse sts)  -- the module itself does not define any names
-            else (self2status m mi,reverse sts)) -- so the empty ident is not needed
+            then (const Nothing,   reverse sts)  -- the module itself does not define any names
+            else (self2status m mi,reverse sts))
 
-modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap)
-modInfo2status (o,mo) = (o,tree2status o (jments mo))
+openSpec2status gr o =
+  do mi <- lookupModule gr (openedModule o)
+     return (o,modInfo2status o mi)
+  where
+    mn = openedModule o
+
+pgf2status o pgf id =
+  case functionType pgf sid of
+    Just _  -> Just (QC (mn, id))
+    Nothing -> case categoryContext pgf sid of
+                 Just _  -> Just (QC (mn, id))
+                 Nothing -> Nothing
+  where
+    sid = showIdent id
+
+    mn = case o of
+           OSimple i   -> i
+           OQualif i j -> j
+
+modInfo2status :: OpenSpec -> ModuleInfo -> StatusMap
+modInfo2status o (ModInfo{jments=jments}) = tree2status o jments
+modInfo2status o (ModPGF pgf) = pgf2status o pgf
 
 self2status :: ModuleName -> ModuleInfo -> StatusMap
-self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
+self2status c m = flip Map.lookup (Map.mapWithKey (info2status (Just c)) (jments m))
 
 
 renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
@@ -241,6 +238,13 @@ renameTerm env vars = ren vars where
       (p',_) <- renpatt p
       return $ EPatt minp maxp p'
 
+    Reset ctl mb_ct t qid -> do
+      mv_ct <- case mb_ct of
+                 Just ct -> liftM Just $ ren vs ct
+                 Nothing -> return mb_ct
+      t <- ren vs t
+      return (Reset ctl mv_ct t qid)
+
     _ -> composOp (ren vs) trm
 
   renid = renameIdentTerm env
@@ -332,7 +336,7 @@ renameContext :: Status -> Context -> Check Context
 renameContext b = renc [] where
   renc vs cont = case cont of
     (bt,x,t) : xts
-      | isWildIdent x -> do
+      | x == identW -> do
           t'   <- ren vs t
           xts' <- renc vs xts
           return $ (bt,x,t') : xts'

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

@@ -57,6 +57,10 @@ extendModule cwd gr (name,m)
    extOne mo (n,cond) = do
      m0 <- lookupModule gr n
 
+     case m0 of
+       ModPGF _ -> checkError ("cannot extend the precompiled module" <+> n)
+       _        -> return ()
+
      -- test that the module types match, and find out if the old is complete
      unless (sameMType (mtype m) (mtype mo))
             (checkError ("illegal extension type to module" <+> name))
@@ -78,7 +82,7 @@ extendModule cwd gr (name,m)
 -- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
-rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
+rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) =
   checkInModule cwd mi NoLoc empty $ do
 
 ----  deps <- moduleDeps ms
@@ -115,7 +119,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
                     else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete)
              (checkError ("module" <+> i <+> "remains incomplete"))
-      ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext
+      ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
       let ops1 = nub $
                    ops_ ++ -- N.B. js has been name-resolved already
                    [OQualif i j | (i,j) <- ops] ++
@@ -131,7 +135,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) =
                                     js
       let js1 = Map.union js0 js_
       let med1= nub (ext : infs ++ insts ++ med_)
-      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1
+      return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1
 
   return (i,mi')
 

src/compiler/api/GF/CompileInParallel.hs

@@ -110,12 +110,12 @@ batchCompile1 lib_dir (opts,filepaths) =
 --            logStrLn $ "Finished "++show (length (modules gr'))++" modules."
               return gr'
      fcache <- liftIO $ newIOCache $ \ _ (imp,Hide (f,ps)) ->
-                 do (file,_,_) <- findFile gfoDir ps imp
+                 do (file,_,_) <- findFile gfoDir ps M.empty imp
                     return (file,(f,ps))
      let find f ps imp =
            do (file',(f',ps')) <- liftIO $ readIOCache fcache (imp,Hide (f,ps))
               when (ps'/=ps) $
-                 do (file,_,_) <- findFile gfoDir ps imp
+                 do (file,_,_) <- findFile gfoDir ps M.empty imp
                     unless (file==file' || any fromPrelude [file,file']) $
                       do eq <- liftIO $ (==) <$> BS.readFile file <*> BS.readFile file'
                          unless eq $

src/compiler/api/GF/CompileOne.hs

@@ -18,7 +18,7 @@ import GF.Grammar.Printer(ppModule,TermPrintQual(..))
 import GF.Grammar.Binary(decodeModule,encodeModule)
 
 import GF.Infra.Option
-import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE)
+import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE,dumpOut,warnOut)
 import GF.Infra.CheckM(runCheck')
 import GF.Data.Operations(ErrorMonad,liftErr,(+++))
 
@@ -27,7 +27,6 @@ import System.FilePath(makeRelative)
 import System.Random(randomIO)
 import qualified Data.Map as Map
 import GF.Text.Pretty(render,(<+>),($$)) --Doc,
-import GF.System.Console(TermColors(..),getTermColors)
 import Control.Monad((<=<))
 import qualified Control.Monad.Fail as Fail
 
@@ -57,7 +56,7 @@ reuseGFO opts srcgr file =
              decodeModule file
      let sm0 = (fst sm00,(snd sm00){mflags=mflags (snd sm00) `addOptions` opts})
 
-     idump opts Source sm0
+     dumpOut opts Source (ppModule Internal sm0)
 
      let sm1 = unsubexpModule sm0
      (sm,warnings) <- -- putPointE Normal opts "creating indirections" $ 
@@ -80,7 +79,7 @@ useTheSource opts srcgr file =
          sm <- putpOpt ("- parsing" +++ rfile)
                        ("- compiling" +++ rfile ++ "... ")
                        (getSourceModule opts file)
-         idump opts Source sm
+         dumpOut opts Source (ppModule Internal sm)
          compileSourceModule opts cwd (Just file) srcgr sm
   where
     putpOpt v m act
@@ -97,8 +96,8 @@ compileSourceModule opts cwd mb_gfFile gr =
     else generateGFO  <=< ifComplete (backend <=< middle) <=< frontend
   where
     -- Apply to all modules
-    frontend = runPass Extend  "" . extendModule cwd gr
-           <=< runPass Rebuild "" . rebuildModule cwd gr
+    frontend = runPass Extend  "extending"  . extendModule cwd gr
+           <=< runPass Rebuild "rebuilding" . rebuildModule cwd gr
 
     -- Apply to complete modules
     middle   = runPass TypeCheck "type checking" . checkModule opts cwd gr
@@ -132,7 +131,7 @@ compileSourceModule opts cwd mb_gfFile gr =
     runPass' ret dump warn lift pass pp m =
         do out <- putpp pp $ lift m
            warnOut opts (warn out)
-           idump opts pass (dump out)
+           dumpOut opts pass (ppModule Internal (dump out))
            return (ret out)
 
     maybeM f = maybe (return ()) f
@@ -151,20 +150,3 @@ writeGFO opts cwd file mo =
     (m,mi) = subexpModule mo
 
     notAnyInd x = case x of AnyInd{} -> False; _ -> True
-
--- to output an intermediate stage
---intermOut :: Options -> Dump -> Doc -> IOE ()
-intermOut opts d doc
-  | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
-  | otherwise   = return ()
-
-idump opts pass = intermOut opts (Dump pass) . ppModule Internal
-
-warnOut opts warnings
-  | null warnings = return ()
-  | otherwise     = do t <- getTermColors
-                       ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
-  where
-    ws = if flag optVerbosity opts == Normal
-         then '\n':warnings
-         else warnings

src/compiler/api/GF/Compiler.hs

@@ -1,16 +1,19 @@
-module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
+module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where
 
 import PGF2
-import PGF2.Internal(unionPGF,writeConcr)
+import PGF2.Transactions
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
 import GF.Compile.ConcreteToHaskell(concretes2haskell)
-import GF.Compile.GrammarToCanonical--(concretes2canonical)
+import GF.Compile.GrammarToCanonical
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
 import GF.Grammar.CFG
+import GF.Grammar.Grammar
+import GF.Grammar.JSON(grammar2json)
+import GF.Grammar.Printer(TermPrintQual(..),ppModule)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
@@ -24,9 +27,9 @@ import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.ByteString.Lazy as BSL
-import GF.Grammar.CanonicalJSON (encodeJSON)
+import Text.JSON (encode)
 import System.FilePath
-import Control.Monad(when,unless,forM_)
+import Control.Monad(when,unless,forM_,foldM)
 
 -- | Compile the given GF grammar files. The result is a number of @.gfo@ files
 -- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
@@ -48,46 +51,32 @@ mainGFC opts fs = do
 
 compileSourceFiles :: Options -> [FilePath] -> IOE ()
 compileSourceFiles opts fs = 
-    do output <- batchCompile opts fs
-       exportCanonical output
-       unless (flag optStopAfterPhase opts == Compile) $
-           linkGrammars opts output
+  do cnc_gr@(cnc,gr) <- S.batchCompile opts Nothing fs
+     let absname = srcAbsName gr cnc
+     exportCanonical absname gr
+     unless (flag optStopAfterPhase opts == Compile) $ do
+       let pgfFile = outputPath opts (grammarName' opts (render absname)<.>"pgf")
+       pgf <- link opts Nothing cnc_gr
+       writeGrammar opts pgf
+       writeOutputs opts pgf
   where
-    batchCompile = maybe batchCompile' parallelBatchCompile (flag optJobs opts)
-    batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs
-                               return (t,[cnc_gr])
-
-    exportCanonical (_time, canonical) =
-      do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $
-           mapM_ cnc2haskell canonical
+    exportCanonical absname gr =
+      do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $ do
+           (res,_) <- runCheck (concretes2haskell opts absname gr)
+           mapM_ writeExport res
          when (FmtCanonicalGF `elem` ofmts) $
            do createDirectoryIfMissing False "canonical"
-              mapM_ abs2canonical canonical
-              mapM_ cnc2canonical canonical
-         when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
+              (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
+              forM_ (modules gr_canon) $ \m@(mn,_) -> do
+                writeExport ("canonical/"++render mn++".gf",render80 (ppModule Unqualified m))
+         when (FmtCanonicalJson `elem` ofmts) $
+           do (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
+              writeExport (render absname ++ ".json", encode (grammar2json gr_canon))
+         when (FmtSourceJson `elem` ofmts) $
+           do writeExport (render absname ++ ".json", encode (grammar2json gr))
       where
         ofmts = flag optOutputFormats opts
 
-    cnc2haskell (cnc,gr) = do
-      (res,_) <- runCheck (concretes2haskell opts (srcAbsName gr cnc) gr)
-      mapM_ writeExport res
-
-    abs2canonical (cnc,gr) = do
-      (canAbs,_) <- runCheck (abstract2canonical absname gr)
-      writeExport ("canonical/"++render absname++".gf",render80 canAbs)
-      where
-        absname = srcAbsName gr cnc
-
-    cnc2canonical (cnc,gr) = do
-      (res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
-      mapM_ (writeExport.fmap render80) res
-
-    grammar2json (cnc,gr) = do
-      (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
-      return (encodeJSON (render absname ++ ".json") gr_canon)
-      where
-        absname = srcAbsName gr cnc
-
     writeExport (path,s) = writing opts path $ writeUTF8File path s
 
 
@@ -96,7 +85,7 @@ compileSourceFiles opts fs =
 -- If a @.pgf@ file by the same name already exists and it is newer than the
 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
 -- recreated. Calls 'writeGrammar' and 'writeOutputs'.
-linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
+linkGrammars opts (t_src,cnc_gr@(cnc,gr)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
        t_pgf <- if outputJustPGF opts
@@ -104,8 +93,7 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
                 else return Nothing
        if t_pgf >= Just t_src
          then putIfVerb opts $ pgfFile ++ " is up-to-date."
-         else do pgfs <- mapM (link opts) cnc_grs
-                 let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
+         else do pgf <- link opts Nothing cnc_gr
                  writeGrammar opts pgf
                  writeOutputs opts pgf
 
@@ -137,16 +125,32 @@ unionPGFFiles opts fs =
            else doIt
 
     doIt =
-      do pgfs <- mapM readPGFVerbose fs
-         let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
-         let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
-         if pgfFile `elem` fs
-           then putStrLnE $ "Refusing to overwrite " ++ pgfFile
-           else writeGrammar opts pgf
-         writeOutputs opts pgf
+      case fs of
+        []     -> return ()
+        (f:fs) -> do mb_probs <- case flag optProbsFile opts of
+                                   Nothing   -> return Nothing
+                                   Just file -> fmap Just (readProbabilitiesFromFile file)
+                     pgf <- if snd (flag optLinkTargets opts)
+                              then case flag optName opts of
+                                     Just name -> do let fname = maybe id (</>) (flag optOutputDir opts) (name<.>"ngf")
+                                                     putStrLnE ("(Boot image "++fname++")")
+                                                     exists <- doesFileExist fname
+                                                     if exists
+                                                       then removeFile fname
+                                                       else return ()
+                                                     echo (\f -> bootNGFWithProbs f mb_probs fname) f
+                                     Nothing   -> do putStrLnE $ "To boot from a list of .pgf files add option -name"
+                                                     echo (\f -> readPGFWithProbs f mb_probs) f
+                              else echo (\f -> readPGFWithProbs f mb_probs) f
+                     pgf <- foldM (\pgf -> echo (modifyPGF pgf . mergePGF)) pgf fs
+                     let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
+                     if pgfFile `elem` fs
+                       then putStrLnE $ "Refusing to overwrite " ++ pgfFile
+                       else writeGrammar opts pgf
+                     writeOutputs opts pgf
+
+    echo read f = putPointE Normal opts ("Reading " ++ f ++ "...") (liftIO (read f))
 
-    readPGFVerbose f =
-        putPointE Normal opts ("Reading " ++ f ++ "...") $ liftIO $ readPGF f
 
 -- | Export the PGF to the 'OutputFormat's specified in the 'Options'.
 -- Calls 'exportPGF'.
@@ -162,22 +166,9 @@ writeOutputs opts pgf = do
 writeGrammar :: Options -> PGF -> IOE ()
 writeGrammar opts pgf =
   if fst (flag optLinkTargets opts)
-    then if flag optSplitPGF opts
-           then writeSplitPGF
-           else writeNormalPGF
+    then do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
+            writing opts outfile (writePGF outfile pgf Nothing)
     else return ()
-  where
-    writeNormalPGF =
-       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-          writing opts outfile (writePGF outfile pgf)
-
-    writeSplitPGF =
-      do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-         writing opts outfile $ writePGF outfile pgf
-         forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do
-           let outfile = outputPath opts (concrname <.> "pgf_c")
-           writing opts outfile (writeConcr outfile concr)
-
 
 writeOutput :: Options -> FilePath-> String -> IOE ()
 writeOutput opts file str = writing opts path $ writeUTF8File path str
@@ -189,7 +180,7 @@ grammarName :: Options -> PGF -> String
 grammarName opts pgf = grammarName' opts (abstractName pgf)
 grammarName' opts abs = fromMaybe abs (flag optName opts)
 
-outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)
+outputJustPGF opts = null (flag optOutputFormats opts)
 
 outputPath opts file = maybe id (</>) (flag optOutputDir opts) file
 

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

@@ -50,6 +50,7 @@ import qualified Data.Map as Map
 import Data.Map (Map)
 --import Control.Applicative(Applicative(..))
 import Control.Monad (liftM,liftM2) --,ap
+import Control.Monad.Fix
 
 import GF.Data.ErrM
 import GF.Data.Relation
@@ -237,6 +238,10 @@ instance ErrorMonad Err where
   handle a@(Ok _) _ = a
   handle (Bad i) f  = f i
 
+instance MonadFix Err where
+  mfix f = let res@(~(Ok x)) = f x in res
+
+
 liftErr e = err raise return e
 {-
 instance ErrorMonad (STM s) where

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

@@ -11,12 +11,14 @@
 -- Basic functions not in the standard libraries
 -----------------------------------------------------------------------------
 
-
+{-# LANGUAGE TupleSections #-}
 module GF.Data.Utilities(module GF.Data.Utilities) where
 
+import Data.Bifunctor (first)
 import Data.Maybe
 import Data.List
-import Control.Monad (MonadPlus(..),liftM,when)
+import Control.Monad (MonadPlus(..),foldM,liftM,liftM2,when)
+import Control.Applicative(liftA2)
 import qualified Data.Set as Set
 
 -- * functions on lists
@@ -30,6 +32,11 @@ notLongerThan, longerThan :: Int -> [a] -> Bool
 notLongerThan n = null . snd . splitAt n
 longerThan    n = not . notLongerThan n
 
+maybeAt :: [a] -> Int -> Maybe a
+maybeAt xs i
+    | i >= 0 && i < length xs = Just (xs !! i)
+    | otherwise               = Nothing
+
 lookupList :: Eq a => a -> [(a, b)] -> [b]
 lookupList a [] = []
 lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
@@ -45,6 +52,14 @@ splitBy p [] = ([], [])
 splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
     where (xs, ys) = splitBy p as
 
+splitAt' :: Int -> [a] -> Maybe ([a], [a])
+splitAt' n xs
+    | n <= 0    = Just ([], xs)
+    | otherwise = helper n xs
+    where helper 0 xs     = Just ([], xs)
+          helper n []     = Nothing
+          helper n (x:xs) = first (x:) <$> helper (n - 1) xs
+
 foldMerge :: (a -> a -> a) -> a -> [a] -> a
 foldMerge merge zero = fm
     where fm [] = zero
@@ -113,7 +128,7 @@ compareBy f = both f compare
 both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
 both f g x y = g (f x) (f y)
 
--- * functions on pairs
+-- * functions on tuples
 
 apFst :: (a -> a') -> (a, b) -> (a', b)
 apFst f (a, b) = (f a, b)
@@ -140,8 +155,44 @@ whenM bm m = flip when m =<< bm
 
 repeatM m = whenM m (repeatM m)
 
+infixr 3 <&&>
+infixr 2 <||>
+
+-- | Boolean conjunction lifted to applicative functors.
+(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
+(<&&>) = liftA2 (&&)
+
+-- | Boolean disjunction lifted to applicative functors.
+(<||>) :: Applicative f => f Bool -> f Bool -> f Bool
+(<||>) = liftA2 (||)
+
+-- | Check whether a monadic predicate holds for every element of a collection.
+allM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool
+allM p = foldM (\b x -> if b then p x else return False) True
+
+-- | Check whether a monadic predicate holds for any element of a collection.
+anyM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool
+anyM p = foldM (\b x -> if b then return True else p x) False
+
+-- | Lifts a monadic action to pairs in the first element.
+firstM :: Monad m => (a -> m a') -> (a, b) -> m (a', b)
+firstM f (a, b) = (,b) <$> f a
+
+-- | Lifts a monadic action to pairs in the second element.
+secondM :: Monad m => (b -> m b') -> (a, b) -> m (a, b')
+secondM f (a, b) = (a,) <$> f b
+
+-- | Lifts a pair of monadic actions to an action on pairs, sequencing left-to-right.
+bimapM :: Monad m => (a -> m a') -> (b -> m b') -> (a, b) -> m (a', b')
+bimapM f g (a, b) = liftM2 (,) (f a) (g b)
+
 -- * functions on Maybes
 
+-- | Returns the argument on the right, or a default value on the left.
+orLeft :: a -> Maybe b -> Either a b
+orLeft a (Just b) = Right b
+orLeft a Nothing  = Left a
+
 -- | Returns true if the argument is Nothing or Just []
 nothingOrNull :: Maybe [a] -> Bool
 nothingOrNull = maybe True null

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

@@ -0,0 +1,284 @@
+    ----------------------------------------------------------------------
+-- |
+-- Module      : XML
+--
+-- Utilities for creating XML documents.
+----------------------------------------------------------------------
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where
+
+import Data.Char(isSpace)
+import Numeric (readHex)
+import GF.Data.Utilities
+
+data XML = Data 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 (escape s)
+    (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
+
+
+-- Lexer -----------------------------------------------------------------------
+
+type Line               = Integer
+type LChar              = (Line,Char)
+type LString            = [LChar]
+data Token              = TokStart Line String [Attr] Bool  -- is empty?
+                        | TokEnd Line String
+                        | TokCRef String
+                        | TokText String
+                          deriving Show
+
+tokens             :: String -> [Token]
+tokens = tokens' . linenumber 1
+
+tokens' :: LString -> [Token]
+tokens' ((_,'<') : c@(_,'!') : cs) = special c cs
+
+tokens' ((_,'<') : cs)   = tag (dropSpace cs) -- we are being nice here
+tokens' [] = []
+tokens' cs@((l,_):_) = let (as,bs) = breakn ('<' ==) cs
+                       in map cvt (decode_text as) ++ tokens' bs
+
+  -- XXX: Note, some of the lines might be a bit inacuarate
+  where cvt (TxtBit x)  = TokText x
+        cvt (CRefBit x) = case cref_to_char x of
+                            Just c -> TokText [c]
+                            Nothing -> TokCRef x
+
+
+special :: LChar -> LString -> [Token]
+special _ ((_,'-') : (_,'-') : cs) = skip cs
+  where skip ((_,'-') : (_,'-') : (_,'>') : ds) = tokens' ds
+        skip (_ : ds) = skip ds
+        skip [] = [] -- unterminated comment
+
+special c ((_,'[') : (_,'C') : (_,'D') : (_,'A') : (_,'T') : (_,'A') : (_,'[')
+         : cs) =
+  let (xs,ts) = cdata cs
+  in TokText xs : tokens' ts
+  where cdata ((_,']') : (_,']') : (_,'>') : ds) = ([],ds)
+        cdata ((_,d) : ds)  = let (xs,ys) = cdata ds in (d:xs,ys)
+        cdata []        = ([],[])
+
+special c cs =
+  let (xs,ts) = munch "" 0 cs
+  in TokText ('<':'!':(reverse xs)) : tokens' ts
+  where munch acc nesting ((_,'>') : ds)
+         | nesting == (0::Int) = ('>':acc,ds)
+         | otherwise           = munch ('>':acc) (nesting-1) ds
+        munch acc nesting ((_,'<') : ds)
+         = munch ('<':acc) (nesting+1) ds
+        munch acc n ((_,x) : ds) = munch (x:acc) n ds
+        munch acc _ [] = (acc,[]) -- unterminated DTD markup
+
+--special c cs = tag (c : cs) -- invalid specials are processed as tags
+
+linenumber :: Integer -> String -> LString
+linenumber n s = 
+  case s of
+    [] -> []
+    ('\r':s') -> case s' of
+                   ('\n':s'') -> next s''
+                   _          -> next s'
+    ('\n':s') -> next s'
+    (c   :s') -> (n,c) : linenumber n s'
+  where
+    next s' = n' `seq` ((n,'\n'):linenumber n' s') where n' = n + 1
+
+
+qualName           :: LString -> (String,LString)
+qualName xs         = breakn endName xs
+  where endName x = isSpace x || x == '=' || x == '>' || x == '/'
+
+
+
+
+
+tag              :: LString -> [Token]
+tag ((p,'/') : cs)    = let (n,ds) = qualName (dropSpace cs)
+                        in TokEnd p n : case (dropSpace ds) of
+                                          (_,'>') : es -> tokens' es
+                                          -- tag was not properly closed...
+                                          _        -> tokens' ds
+tag []            = []
+tag cs            = let (n,ds)  = qualName cs
+                        (as,b,ts) = attribs (dropSpace ds)
+                    in TokStart (fst (head cs)) n as b : ts
+
+attribs          :: LString -> ([Attr], Bool, [Token])
+attribs cs        = case cs of
+                      (_,'>') : ds -> ([], False, tokens' ds)
+
+                      (_,'/') : ds -> ([], True, case ds of
+                                              (_,'>') : es -> tokens' es
+                                              -- insert missing >  ...
+                                              _ -> tokens' ds)
+
+                      (_,'?') : (_,'>') : ds -> ([], True, tokens' ds)
+
+                      -- doc ended within a tag..
+                      []       -> ([],False,[])
+
+                      _        -> let (a,cs1) = attrib cs
+                                      (as,b,ts) = attribs cs1
+                                  in (a:as,b,ts)
+
+attrib             :: LString -> (Attr,LString)
+attrib cs           = let (ks,cs1)  = qualName cs
+                          (vs,cs2)  = attr_val (dropSpace cs1)
+                      in ((ks,decode_attr vs),dropSpace cs2)
+
+attr_val           :: LString -> (String,LString)
+attr_val ((_,'=') : cs) = string (dropSpace cs)
+attr_val cs         = ("",cs)
+
+
+dropSpace :: LString -> LString
+dropSpace = dropWhile (isSpace . snd)
+
+-- | Match the value for an attribute.  For malformed XML we do
+-- our best to guess the programmer's intention.
+string             :: LString -> (String,LString)
+string ((_,'"') : cs)   = break' ('"' ==) cs
+
+-- Allow attributes to be enclosed between ' '.
+string ((_,'\'') : cs)  = break' ('\'' ==) cs
+
+-- Allow attributes that are not enclosed by anything.
+string cs           = breakn eos cs
+  where eos x = isSpace x || x == '>' || x == '/'
+
+
+break' :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
+break' p xs         = let (as,bs) = breakn p xs
+                      in (as, case bs of
+                                [] -> []
+                                _ : cs -> cs)
+
+breakn :: (a -> Bool) -> [(b,a)] -> ([a],[(b,a)])
+breakn p l = (map snd as,bs) where (as,bs) = break (p . snd) l
+
+
+
+decode_attr :: String -> String
+decode_attr cs = concatMap cvt (decode_text cs)
+  where cvt (TxtBit x) = x
+        cvt (CRefBit x) = case cref_to_char x of
+                            Just c -> [c]
+                            Nothing -> '&' : x ++ ";"
+
+data Txt = TxtBit String | CRefBit String deriving Show
+
+decode_text :: [Char] -> [Txt]
+decode_text xs@('&' : cs) = case break (';' ==) cs of
+                              (as,_:bs) -> CRefBit as : decode_text bs
+                              _ -> [TxtBit xs]
+decode_text []  = []
+decode_text cs  = let (as,bs) = break ('&' ==) cs
+                  in TxtBit as : decode_text bs
+
+cref_to_char :: [Char] -> Maybe Char
+cref_to_char cs = case cs of
+  '#' : ds  -> num_esc ds
+  "lt"      -> Just '<'
+  "gt"      -> Just '>'
+  "amp"     -> Just '&'
+  "apos"    -> Just '\''
+  "quot"    -> Just '"'
+  _         -> Nothing
+
+num_esc :: String -> Maybe Char
+num_esc cs = case cs of
+               'x' : ds -> check (readHex ds)
+               _        -> check (reads cs)
+
+  where check [(n,"")]  = cvt_char n
+        check _         = Nothing
+
+cvt_char :: Int -> Maybe Char
+cvt_char x
+  | fromEnum (minBound :: Char) <= x && x <= fromEnum (maxBound::Char)
+                = Just (toEnum x)
+  | otherwise = Nothing
+
+
+-- Parser --------------------------------------------------------------
+
+-- | parseXML to a list of content chunks
+parseXML :: String -> [XML]
+parseXML  = parse . tokens
+
+------------------------------------------------------------------------
+
+parse      :: [Token] -> [XML]
+parse []    = []
+parse ts    = let (es,_,ts1) = nodes [] ts
+              in es ++ parse ts1
+
+nodes :: [String] -> [Token] -> ([XML], [String], [Token])
+nodes ps (TokCRef ref : ts) =
+  let (es,qs,ts1) = nodes ps ts
+  in (Data ref : es, qs, ts1)
+nodes ps (TokText txt : ts) =
+  let (es,qs,ts1) = nodes ps ts
+      (more,es1)  = case es of
+                      Data cd : es1' -> (cd,es1')
+                      _              -> ([],es)
+  in (Data (txt ++ more) : es1, qs, ts1)
+nodes ps (TokStart p t as empty : ts) = (node : siblings, open, toks)
+  where
+    (node,(siblings,open,toks))
+      | empty     = (ETag t as, nodes ps ts)
+      | otherwise = let (es1,qs1,ts1) = nodes (t:ps) ts
+                    in (Tag t as es1,
+                        case qs1 of
+                          [] -> nodes ps ts1
+                          _ : qs3 -> ([],qs3,ts1))
+nodes ps (TokEnd p t : ts)   = case break (t ==) ps of
+                                  (as,_:_) -> ([],as,ts)
+                                  -- Unknown closing tag. Insert as text.
+                                  (_,[]) ->
+                                    let (es,qs,ts1) = nodes ps ts
+                                    in (Data "" : es,qs,ts1)
+nodes ps []                 = ([],ps,[])

src/compiler/api/GF/Grammar.hs

@@ -16,12 +16,16 @@ module GF.Grammar
            ( module GF.Grammar.Grammar,
              module GF.Grammar.Values,
              module GF.Grammar.Macros,
+             module GF.Grammar.Parser,
              module GF.Grammar.Printer,
+             module GF.Grammar.Predef,
              module GF.Infra.Ident
            ) where
 
 import GF.Grammar.Grammar
 import GF.Grammar.Values
 import GF.Grammar.Macros
+import GF.Grammar.Parser
 import GF.Grammar.Printer
+import GF.Grammar.Predef
 import GF.Infra.Ident

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

@@ -28,25 +28,14 @@ import PGF2.Transactions(Symbol(..))
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF05"
 
-instance Binary Ident where
-  put id = put (ident2utf8 id)
-  get    = do bs <- get
-              if bs == BS.pack "_"
-                then return identW
-                else return (identC (rawIdentC bs))
-
-instance Binary ModuleName where
-  put (MN id) = put id
-  get = fmap MN get
-
 instance Binary Grammar where
   put = put . modules
   get = fmap mGrammar get
 
 instance Binary ModuleInfo where
-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
-  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
-              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
+  get    = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
+              return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
 
 instance Binary ModuleType where
   put MTAbstract       = putWord8 0
@@ -103,13 +92,17 @@ instance Binary Options where
              toString (LInt n) = show n
              toString (LFlt d) = show d
 
-instance Binary PMCFGCat where
-  put (PMCFGCat r rs) = put (r,rs)
-  get = get >>= \(r,rs) -> return (PMCFGCat r rs)
+instance Binary LParam where
+  put (LParam r rs) = put (r,rs)
+  get = get >>= \(r,rs) -> return (LParam r rs)
 
-instance Binary PMCFGRule where
-  put (PMCFGRule res args rules) = put (res,args,rules)
-  get = get >>= \(res,args,rules) -> return (PMCFGRule res args rules)
+instance Binary PArg where
+  put (PArg x y) = put (x,y)
+  get = get >>= \(x,y) -> return (PArg x y)
+
+instance Binary Production where
+  put (Production ps args res rules) = put (ps,args,res,rules)
+  get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules)
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
@@ -182,8 +175,10 @@ instance Binary Term where
   put (ELincat x y) = putWord8 30 >> put (x,y)
   put (ELin x y)    = putWord8 31 >> put (x,y)
   put (FV x)        = putWord8 32 >> put x
-  put (Alts x y)    = putWord8 33 >> put (x,y)
-  put (Strs x)      = putWord8 34 >> put x
+  put (Markup x y z)= putWord8 33 >> put (x,y,z)
+  put (Reset w x y z)=putWord8 34 >> put (w,x,y,z)
+  put (Alts x y)    = putWord8 35 >> put (x,y)
+  put (Strs x)      = putWord8 36 >> put x
 
   get = do tag <- getWord8
            case tag of
@@ -220,8 +215,10 @@ instance Binary Term where
              30 -> get >>= \(x,y)   -> return (ELincat x y)
              31 -> get >>= \(x,y)   -> return (ELin x y)
              32 -> get >>= \x       -> return (FV x)
-             33 -> get >>= \(x,y)   -> return (Alts x y)
-             34 -> get >>= \x       -> return (Strs x)
+             33 -> get >>= \(x,y,z) -> return (Markup x y z)
+             34 -> get >>= \(w,x,y,z)->return (Reset w x y z)
+             35 -> get >>= \(x,y)   -> return (Alts x y)
+             36 -> get >>= \x       -> return (Strs x)
              _  -> decodingError
 
 instance Binary Patt where
@@ -312,8 +309,8 @@ instance Binary Literal where
              _ -> decodingError
 
 instance Binary Symbol where
-  put (SymCat d r rs)    = putWord8 0 >> put (d,r,rs)
-  put (SymLit n l)       = putWord8 1 >> put (n,l)
+  put (SymCat d r)       = putWord8 0 >> put (d,r)
+  put (SymLit d r)       = putWord8 1 >> put (d,r)
   put (SymVar n l)       = putWord8 2 >> put (n,l)
   put (SymKS ts)         = putWord8 3 >> put ts
   put (SymKP d vs)       = putWord8 4 >> put (d,vs)
@@ -325,7 +322,7 @@ instance Binary Symbol where
   put SymALL_CAPIT       = putWord8 10
   get = do tag <- getWord8
            case tag of
-             0 -> liftM3 SymCat get get get
+             0 -> liftM2 SymCat get get
              1 -> liftM2 SymLit get get
              2 -> liftM2 SymVar get get
              3 -> liftM  SymKS  get
@@ -372,7 +369,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
 decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
   where
     conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
-        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty)
+        (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
 
 encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
 encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)

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

@@ -53,6 +53,7 @@ module GF.Grammar.Grammar (
         Equation,
         Labelling,
         Assign,
+        Option,
         Case,
         LocalDef,
         Param,
@@ -64,7 +65,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        PMCFGCat(..), PMCFGRule(..)
+        LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
         ) where
 
 import GF.Infra.Ident
@@ -73,25 +74,27 @@ import GF.Infra.Location
 
 import GF.Data.Operations
 
-import PGF2(BindType(..))
-import PGF2.Transactions(Symbol,LIndex,LParam)
+import PGF2(BindType(..),PGF)
+import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
 import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
 import GF.Text.Pretty
 
 
 -- | A grammar is a self-contained collection of grammar modules
 data Grammar = MGrammar { 
     moduleMap :: Map.Map ModuleName ModuleInfo,
-    modules :: [Module]
+    modules   :: [Module]
   }
 
 -- | Modules
 type Module = (ModuleName, ModuleInfo)
 
-data ModuleInfo = ModInfo {
+data ModuleInfo
+ = ModInfo {
     mtype   :: ModuleType,
     mstatus :: ModuleStatus,
     mflags  :: Options,
@@ -100,8 +103,12 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
+    mseqs   :: Maybe (Seq.Seq [Symbol]),
     jments  :: Map.Map Ident Info
-  }
+   }
+ | ModPGF {
+    mpgf :: PGF
+   }
 
 type SourceGrammar = Grammar
 type SourceModule = Module
@@ -304,12 +311,6 @@ allConcreteModules gr =
   [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
 
 
-data PMCFGCat  = PMCFGCat LIndex [(LIndex,LParam)]
-                 deriving (Eq,Show)
-
-data PMCFGRule = PMCFGRule PMCFGCat [PMCFGCat] [[Symbol]]
-                 deriving (Eq,Show)
-
 -- | the constructors are judgements in 
 --
 --   - abstract syntax (/ABS/)
@@ -335,16 +336,16 @@ data Info =
  | ResOverload [ModuleName] [(L Type,L Term)]        -- ^ (/RES/) idents: modules inherited
 
 -- judgements in concrete syntax
- | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) lindef ini'zed, 
- | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) type info added at 'TC'
+ | CncCat  (Maybe (L Type))                     (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
   deriving Show
 
-type Type = Term
-type Cat  = QIdent
-type Fun  = QIdent
+type Type    = Term
+type Cat     = QIdent
+type Fun     = QIdent
 
 type QIdent = (ModuleName,Ident)
 
@@ -371,7 +372,9 @@ data Term =
  | R [Assign]                    -- ^ record:      @{ p = a ; ...}@
  | P Term Label                  -- ^ projection:  @r.p@
  | ExtR Term Term                -- ^ extension:   @R ** {x : A}@ (both types and terms)
- 
+
+ | Opts Term [Option]            -- ^ options:     @options s in { e => x ; ... }@
+
  | Table Term Term               -- ^ table type:  @P => A@
  | T TInfo [Case]                -- ^ table:       @table {p => c ; ...}@
  | V Type [Term]                 -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
@@ -391,13 +394,15 @@ data Term =
  | ELincat Ident Term            -- ^ boxed linearization type of Ident
  | ELin Ident Term               -- ^ boxed linearization of type Ident
 
- | AdHocOverload [Term]          -- ^ ad hoc overloading generated in Rename
-
  | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
 
+ | Markup Ident [(Ident,Term)] [Term]
+ | Reset Ident (Maybe Term) Term (Maybe QIdent)
+
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
  | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
- | TSymCat Int LIndex [(LIndex,Ident)]
+ | TSymCat Int LIndex [(LIndex,(Ident,Type))]
+ | TSymVar Int Int
   deriving (Show, Eq, Ord)
 
 -- | Patterns
@@ -459,6 +464,7 @@ type Equation = ([Patt],Term)
 
 type Labelling = (Label, Type) 
 type Assign = (Label, (Maybe Type, Term)) 
+type Option = (Maybe Term, Term)
 type Case = (Patt, Term) 
 --type Cases = ([Patt], Term) 
 type LocalDef = (Ident, (Maybe Type, Term))

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

@@ -0,0 +1,281 @@
+module GF.Grammar.JSON( TermPrintQual(..),
+                        grammar2json,
+                        term2json, json2term,
+                        patt2json, json2patt
+                      ) where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Printer(TermPrintQual(..))
+import Text.JSON
+import Text.JSON.Types
+import Control.Monad (forM,(>=>),liftM2,guard)
+import Control.Applicative ((<|>))
+import qualified Data.Map as Map
+import Data.Maybe (catMaybes)
+
+grammar2json :: Grammar -> JSValue
+grammar2json gr =
+  makeObj [(showIdent mn, mi2json mi) | (MN mn,mi) <- modules gr]
+
+mi2json mi = makeObj [("type", mtype2json (mtype mi))
+                     ,("jments",makeObj (map jment2json (Map.toList (jments mi))))
+                     ]
+
+mtype2json MTAbstract     = showJSON "abstract"
+mtype2json MTResource     = showJSON "resource"
+mtype2json (MTConcrete _) = showJSON "concrete"
+mtype2json MTInterface    = showJSON "interface"
+mtype2json (MTInstance _) = showJSON "instance"
+
+jment2json (id,info) = (showIdent id, info2json info)
+
+info2json (AbsCat mb_ctxt) =
+  case mb_ctxt of
+    Nothing         -> makeObj []
+    Just (L _ ctxt) -> makeObj [("context", showJSON (map hypo2json ctxt))]
+info2json (AbsFun mb_ty mb_arity mb_eqs _) =
+  (makeObj . catMaybes)
+     [ fmap (\(L _ ty) -> ("abstype",term2json ty)) mb_ty
+     , fmap (\a -> ("arity",showJSON a)) mb_arity
+     , fmap (\eqs -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs
+     ]
+info2json (ResParam mb_params _) =
+  makeObj [("params", case mb_params of
+                         Nothing           -> JSArray []
+                         Just (L _ params) -> showJSON (map param2json params))]
+info2json (ResValue (L _ ty) _) =
+  makeObj [("paramtype",term2json ty)]
+info2json (ResOper mb_ty mb_def) =
+  (makeObj . catMaybes)
+     [ fmap (\(L _ ty) -> ("opertype",term2json ty)) mb_ty
+     , fmap (\(L _ def) -> ("operdef",term2json def)) mb_def
+     ]
+info2json (ResOverload mns overloads) =
+  makeObj
+     [ ("extends",showJSON mns)
+     , ("overloads",showJSON (map overload2json overloads))
+     ]
+info2json (CncCat mb_ty mb_lindef mb_linref mb_pnm _) =
+  (makeObj . catMaybes)
+     [ fmap (\(L _ ty) -> ("lintype",term2json ty)) mb_ty
+     , fmap (\(L _ def) -> ("lindef",term2json def)) mb_lindef
+     , fmap (\(L _ ref) -> ("linref",term2json ref)) mb_linref
+     , fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
+     ]
+info2json (CncFun _ mb_lin mb_pnm _) =
+  (makeObj . catMaybes)
+     [ fmap (\(L _ lin) -> ("lin",term2json lin)) mb_lin
+     , fmap (\(L _ prn) -> ("printname",term2json prn)) mb_pnm
+     ]
+info2json (AnyInd _ mn) = showJSON mn
+
+hypo2json (bt,x,ty) =
+  makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("type", term2json ty)]
+
+equation2json (ps,t) =
+  makeObj [("patts", showJSON (map patt2json ps)), ("term", term2json t)]
+
+param2json (id, ctxt) =
+  makeObj [("id", showJSON id), ("context", showJSON (map hypo2json ctxt))]
+
+overload2json (L _ ty,L _ def) =
+  makeObj
+     [ ("opertype",term2json ty)
+     , ("operdef",term2json def)
+     ]
+
+term2json :: Term -> JSValue
+term2json (Vr v) = makeObj [("vr", showJSON v)]
+term2json (Cn v) = makeObj [("cn", showJSON v)]
+term2json (Con v) = makeObj [("con", showJSON v)]
+term2json (Sort v) = makeObj [("sort", showJSON v)]
+term2json (EInt n) = showJSON n
+term2json (EFloat f) = showJSON f
+term2json (K s) = showJSON s
+term2json Empty = JSArray []
+term2json (App t1 t2) = makeObj [("fun", term2json t1), ("arg", term2json t2)]
+term2json (Abs bt x t) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON x), ("body", term2json t)]
+term2json (Meta id) = makeObj [("metaid", showJSON id)]
+term2json (ImplArg t) = makeObj [("implarg", term2json t)]
+term2json (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), ("var", showJSON v), ("hypo", term2json t1), ("res", term2json t2)]
+term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)]
+term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)]
+term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))]
+                              where toRow (l,t) = (showLabel l, term2json t)
+term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))]
+                              where toRow (l,(_,t)) = (showLabel l, term2json t)
+term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))]
+term2json (ExtR t1 t2) = makeObj [("term", term2json t1), ("ext", term2json t2)]
+term2json (Table t1 t2) = makeObj [("tblhypo", term2json t1), ("tblres", term2json t2)]
+term2json (T _ cs) = makeObj [("tblcases", showJSON [(patt2json p, term2json t) | (p,t) <- cs])]
+term2json (V ty ts) = makeObj [("tbltype", term2json ty), ("tblvalues", showJSON (map term2json ts))]
+term2json (S t1 t2) = makeObj [("select", term2json t1), ("key", term2json t2)]
+term2json (Let (v,(_,t1)) t2) = makeObj [("letvar", showJSON v), ("letdef", term2json t1), ("term", term2json t2)]
+term2json (Q (m,id))  = makeObj [("mod",showJSON m),("q",  showJSON id)]
+term2json (QC (m,id)) = makeObj [("mod",showJSON m),("qc", showJSON id)]
+term2json (C t1 t2) = showJSON ((flatten t1 . flatten t2) [])
+    where
+      flatten Empty     = id
+      flatten (C t1 t2) = flatten t1 . flatten t2
+      flatten t         = (term2json t :)
+term2json (Glue t1 t2) = makeObj [("glue1",term2json t1),("glue2", term2json t2)]
+term2json (EPattType t) = makeObj [("patttype",term2json t)]
+term2json (ELincat id t) = makeObj [("lincat",showJSON id), ("term",term2json t)]
+term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
+term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
+term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
+                                                , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
+                                                , ("children",showJSON (map term2json children))
+                                                ]
+term2json (Reset ctl ct t qid) =
+  makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
+term2json (Alts def alts) = makeObj [("def",term2json def), ("alts",showJSON (map (\(t1,t2) -> (term2json t1, term2json t2)) alts))]
+term2json (Strs ts) = makeObj [("strs",showJSON (map term2json ts))]
+term2json (EPatt _ _ p) = makeObj [("epatt",patt2json p)]
+
+
+json2term o  = Vr      <$> o!:"vr"
+    <|>  curry Q       <$> o!:"mod" <*> o!:"cn"
+    <|>  curry QC      <$> o!:"mod" <*> o!:"con"
+    <|>        Cn      <$> o!:"cn"
+    <|>        Con     <$> o!:"con"
+    <|>        Sort    <$> o!:"sort"
+    <|>        EInt    <$> readJSON o
+    <|>        EFloat  <$> readJSON o
+    <|>        K       <$> readJSON o
+    <|>        App     <$> o!<"fun" <*> o!<"arg"
+    <|>        Abs     <$> fmap toBindType (o!:"implicit") <*> o!:"var" <*> o!<"body"
+    <|>        Meta    <$> o!:"metaid"
+    <|>        ImplArg <$> o!<"implarg"
+    <|>        Prod    <$> fmap toBindType (o!:"implicit") <*> o!:"var" <*> o!<"hypo" <*> o!<"res"
+    <|>        Typed   <$> o!<"term" <*> o!<"type"
+    <|>        Example <$> o!<"term" <*> o!:"example"
+    <|>        RecType <$> (o!:"rectype" >>= \o -> mapM fromRow  (assocsJSObject o))
+    <|>        R       <$> (o!:"record"  >>= \o -> mapM fromRow' (assocsJSObject o))
+    <|>        P       <$> o!<"project" <*> fmap readLabel (o!:"label")
+    <|>        ExtR    <$> o!<"term" <*> o!<"ext"
+    <|>        Table   <$> o!<"tblhypo" <*> o!<"tblres"
+    <|>        do o  <- readJSON o
+                  cs <- valFromObj "tblcases" o
+                  cs <- forM cs $ \(p,t) -> do
+                          p <- json2patt p
+                          t <- json2term t
+                          return (p,t)
+                  return (T TRaw cs)
+    <|>        do o  <- readJSON o
+                  ty <- valFromObj "tbltype" o >>= json2term
+                  ts <- valFromObj "tblvalues" o >>= mapM json2term
+                  return (V ty ts)
+    <|>        S       <$> o!<"select" <*> o!<":.key"
+    <|>  (\v t1 -> Let (v,(Nothing,t1))) <$> o!:"letvar" <*> o!<"letdef" <*> o!<"term"
+    <|>      mkC       <$> (readJSON o >>= mapM json2term)
+    <|>        Glue    <$> o!<"glue1" <*> o!<"glue2"
+    <|>      EPattType <$> o!<"patttype"
+    <|>        ELincat <$> o!:"lincat" <*> o!<"term"
+    <|>        ELin    <$> o!:"lin" <*> o!<"term"
+    <|>        FV      <$> (o!:"variants" >>= mapM json2term)
+    <|>        Markup  <$> (o!:"tag") <*>
+                           (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
+                           (o!:"children" >>= mapM json2term)
+    <|>        Reset   <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
+    <|>        Reset   <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
+    <|>        Alts    <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))
+    <|>        Strs    <$> (o!:"strs" >>= mapM json2term)
+    where
+      fromRow  (lbl, jsvalue) = do value <- json2term jsvalue
+                                   return (readLabel lbl,value)
+
+      fromRow' (lbl, jsvalue) = do value <- json2term jsvalue
+                                   return (readLabel lbl,(Nothing,value))
+
+      toBindType True  = Implicit
+      toBindType False = Explicit
+
+      mkC []     = Empty
+      mkC (t:ts) = foldl C t ts
+
+patt2json (PC id ps)     = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
+patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
+patt2json (PV id)        = makeObj [("pv",showJSON id)]
+patt2json PW             = makeObj [("wildcard",showJSON True)]
+patt2json (PR lbls)      = makeObj (("record", showJSON True) : map toRow lbls)
+                               where toRow (l,t) = (showLabel l, patt2json t)
+patt2json (PString s)    = showJSON s
+patt2json (PInt n)       = showJSON n
+patt2json (PFloat d)     = showJSON d
+patt2json (PT ty p)      = makeObj [("type", term2json ty), ("patt", patt2json p)]
+patt2json (PAs id p)     = makeObj [("as", showJSON id), ("patt", patt2json p)]
+patt2json (PImplArg p)   = makeObj [("implarg", patt2json p)]
+patt2json (PTilde t)     = makeObj [("tilde", term2json t)]
+patt2json (PNeg p)       = makeObj [("neg", patt2json p)]
+patt2json (PAlt p1 p2)   = makeObj [("alt1", patt2json p1), ("alt2", patt2json p2)]
+patt2json (PSeq min1 max1 p1 min2 max2 p2)
+                           = makeObj [("min1",  showJSON min1)
+                                     ,("max1",  showJSON max1)
+                                     ,("patt1", patt2json p1)
+                                     ,("min2",  showJSON min2)
+                                     ,("max2",  showJSON max2)
+                                     ,("patt2", patt2json p2)
+                                     ]
+patt2json (PRep min max p)=makeObj [("min",  showJSON min)
+                                   ,("max",  showJSON max)
+                                   ,("patt", patt2json p)
+                                   ]
+patt2json PChar          = makeObj [("char",showJSON True)]
+patt2json (PChars cs)    = makeObj [("chars",showJSON cs)]
+patt2json (PMacro id)    = makeObj [("macro",showJSON id)]
+patt2json (PM (mn,id))   = makeObj [("mod",showJSON mn), ("macro",showJSON id)]
+
+json2patt :: JSValue -> Result Patt
+json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt)
+    <|>       PC <$> (o!:"pc") <*> (o!:"args" >>= mapM json2patt)
+    <|>       PV <$> (o!:"pv")
+    <|>  (o!:"wildcard" >>= guard >> return PW)
+    <|> (const PR) <$> (o!:"record" >>= guard) <*> mapM fromRow (assocsJSObject o)
+    <|>  PString <$> readJSON o
+    <|>  PInt    <$> readJSON o
+    <|>  PFloat  <$> readJSON o
+    <|>  PT      <$> o!<"type" <*> o!>"patt"
+    <|>  PAs     <$> o!:"as" <*> o!>"patt"
+    <|>  PImplArg<$> o!>"implarg"
+    <|>  PTilde  <$> o!<"tilde"
+    <|>  PNeg    <$> o!>"neg"
+    <|>  PAlt    <$> o!>"alt1" <*> o!>"alt2"
+    <|>  PSeq    <$> o!:"min1" <*> o!:"max1" <*> o!>"patt1" <*> o!:"min2" <*> o!:"max2" <*> o!>"patt2"
+    <|>  PRep    <$> o!:"min" <*> o!:"max" <*> o!>"rep"
+    <|>  (o!:"char" >>= guard >> return PChar)
+    <|>  PChars  <$> o!:"chars"
+    <|>  PM      <$> liftM2 (,) (o!:"mod") (o!:"macro")
+    <|>  PMacro  <$> o!:"macro"
+    where
+      fromRow  (lbl, jsvalue) = do patt <- json2patt jsvalue
+                                   return (readLabel lbl,patt)
+
+
+showLabel :: Label -> String
+showLabel (LIdent s) = showRawIdent s
+showLabel (LVar i)   = '$':show i
+
+readLabel ('$':s) = LVar (read s)
+readLabel s = LIdent (rawIdentS s)
+
+(!<) :: JSValue -> String -> Result Term
+obj !< key = maybe (fail $ "(!<): could not find key: " ++ key)
+            json2term
+            (lookup key (assocsJSObject obj))
+
+(!>) :: JSValue -> String -> Result Patt
+obj !> key = maybe (fail $ "(!>): could not find key: " ++ key)
+             json2patt
+             (lookup key (assocsJSObject obj))
+
+(!:) :: JSON a => JSValue -> String -> Result a
+obj !: key = maybe (fail $ "(!:): could not find key: " ++ key)
+             readJSON
+             (lookup key (assocsJSObject obj))
+
+assocsJSObject :: JSValue -> [(String, JSValue)]
+assocsJSObject (JSObject o) = fromJSObject o
+assocsJSObject (JSArray  _) = fail $ "assocsJSObject: Expected a JSON object, found an Array"
+assocsJSObject  jsvalue     = fail $ "assocsJSObject: Expected a JSON object, found " ++ show jsvalue