more comments

Always use UTF8 encoding in the gf executable

.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

@@ -1,216 +0,0 @@
-name: Build majestic runtime
-
-on: push
-
-env:
-  LD_LIBRARY_PATH: /usr/local/lib
-
-jobs:
-
-  ubuntu-runtime:
-    name: Runtime (Ubuntu)
-    runs-on: ubuntu-20.04
-
-    steps:
-    - uses: actions/checkout@v2
-
-    - name: Build runtime
-      working-directory: ./src/runtime/c
-      run: |
-        autoreconf -i
-        ./configure
-        make
-        sudo make install
-
-    - name: Upload artifact
-      uses: actions/upload-artifact@master
-      with:
-        name: libpgf-ubuntu
-        path: |
-          /usr/local/lib/libpgf*
-          /usr/local/include/pgf
-
-  ubuntu-haskell:
-    name: Haskell (Ubuntu)
-    runs-on: ubuntu-20.04
-    needs: ubuntu-runtime
-
-    steps:
-    - uses: actions/checkout@v2
-    - name: Download artifact
-      uses: actions/download-artifact@master
-      with:
-        name: libpgf-ubuntu
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
-
-    - name: Setup Haskell
-      uses: haskell/actions/setup@v1
-
-    - name: Build & run testsuite
-      working-directory: ./src/runtime/haskell
-      run: |
-        cabal test --extra-lib-dirs=/usr/local/lib
-
-  ubuntu-python:
-    name: Python (Ubuntu)
-    runs-on: ubuntu-20.04
-    needs: ubuntu-runtime
-
-    steps:
-    - uses: actions/checkout@v2
-    - name: Download artifact
-      uses: actions/download-artifact@master
-      with:
-        name: libpgf-ubuntu
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
-
-    - name: Install bindings
-      working-directory: ./src/runtime/python
-      run: |
-        python setup.py build
-        sudo python setup.py install
-
-    - name: Run testsuite
-      working-directory: ./src/runtime/python
-      run: |
-        pip install pytest
-        pytest
-
-  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
-      with:
-        name: libpgf-ubuntu
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
-
-    - name: Install dependencies
-      working-directory: ./src/runtime/javascript
-      run: |
-        npm ci
-
-    - name: Run testsuite
-      working-directory: ./src/runtime/javascript
-      run: |
-        npm run test
-
-# ----------------------------------------------------------------------------
-
-  macos-runtime:
-    name: Runtime (macOS)
-    runs-on: macOS-11
-
-    steps:
-    - uses: actions/checkout@v2
-
-    - name: Install build tools
-      run: |
-        brew install \
-          autoconf \
-          automake \
-          libtool \
-
-    - name: Build runtime
-      working-directory: ./src/runtime/c
-      run: |
-        glibtoolize
-        autoreconf -i
-        ./configure
-        make
-        sudo make install
-
-    - name: Upload artifact
-      uses: actions/upload-artifact@master
-      with:
-        name: libpgf-macos
-        path: |
-          /usr/local/lib/libpgf*
-          /usr/local/include/pgf
-
-  macos-haskell:
-    name: Haskell (macOS)
-    runs-on: macOS-11
-    needs: macos-runtime
-
-    steps:
-    - uses: actions/checkout@v2
-    - name: Download artifact
-      uses: actions/download-artifact@master
-      with:
-        name: libpgf-macos
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
-
-    - name: Setup Haskell
-      uses: haskell/actions/setup@v1
-
-    - name: Build & run testsuite
-      working-directory: ./src/runtime/haskell
-      run: |
-        cabal test --extra-lib-dirs=/usr/local/lib
-
-  macos-python:
-    name: Python (macOS)
-    runs-on: macOS-11
-    needs: macos-runtime
-
-    steps:
-    - uses: actions/checkout@v2
-    - name: Download artifact
-      uses: actions/download-artifact@master
-      with:
-        name: libpgf-macos
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
-
-    - name: Install bindings
-      working-directory: ./src/runtime/python
-      run: |
-        python3 setup.py build
-        sudo python3 setup.py install
-
-    - name: Run testsuite
-      working-directory: ./src/runtime/python
-      run: |
-        pip3 install pytest
-        pytest
-
-  macos-javascript:
-    name: JavaScript (macOS)
-    runs-on: macOS-11
-    needs: macos-runtime
-    if: false
-
-    steps:
-    - uses: actions/checkout@v2
-    - name: Download artifact
-      uses: actions/download-artifact@master
-      with:
-        name: libpgf-macos
-    - run: |
-        sudo mv lib/* /usr/local/lib/
-        sudo mv include/* /usr/local/include/
-
-    - name: Install dependencies
-      working-directory: ./src/runtime/javascript
-      run: |
-        npm ci
-
-    - name: Run testsuite
-      working-directory: ./src/runtime/javascript
-      run: |
-        npm run test

.gitignore

@@ -5,7 +5,6 @@
 *.jar
 *.gfo
 *.pgf
-*.ngf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf
@@ -47,8 +46,6 @@ src/runtime/c/sg/.dirstamp
 src/runtime/c/stamp-h1
 src/runtime/java/.libs/
 src/runtime/python/build/
-src/runtime/python/**/__pycache__/
-src/runtime/python/**/.pytest_cache/
 .cabal-sandbox
 cabal.sandbox.config
 .stack-work

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/hackers-guide/CompilationOverview.md

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

doc/hackers-guide/DESIDERATA.md

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

doc/hackers-guide/README.md

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

doc/hackers-guide/abstract_expressions.md

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

doc/hackers-guide/memory_model.md

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

doc/hackers-guide/transactions.md

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

gf.cabal

@@ -8,12 +8,17 @@ license-file: LICENSE
 category: Natural Language Processing, Compiler
 synopsis: Grammatical Framework
 description: GF, Grammatical Framework, is a programming language for multilingual grammar applications
+maintainer: John J. Camilleri <john@digitalgrammars.com>
 homepage: https://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4, GHC==9.0.2
 
 data-dir: src
-extra-source-files: WebSetup.hs
+extra-source-files:
+  README.md
+  CHANGELOG.md
+  WebSetup.hs
+  doc/Logos/gf0.png
 data-files:
   www/*.html
   www/*.css
@@ -41,7 +46,7 @@ data-files:
 
 custom-setup
   setup-depends:
-    base >= 4.9.1 && < 4.15,
+    base >= 4.9.1 && < 4.16,
     Cabal >= 1.22.0.0,
     directory >= 1.3.0 && < 1.4,
     filepath >= 1.4.1 && < 1.5,
@@ -63,38 +68,128 @@ flag network-uri
    description: Get Network.URI from the network-uri package
    default: True
 
-executable gf
-  hs-source-dirs: src/programs, src/compiler
-  main-is: gf-main.hs
-  default-language:    Haskell2010
-  build-depends: pgf2,
-                 base >= 4.6 && <5,
-                 array,
-                 containers,
-                 bytestring,
-                 utf8-string,
-                 random,
-                 pretty,
-                 mtl,
-                 exceptions,
-                 ghc-prim,
-                 filepath, directory>=1.2, time,
-                 process, haskeline, parallel>=3, json
-  ghc-options: -threaded
+--flag new-comp
+--  Description: Make -new-comp the default
+--  Default:     True
+
+flag c-runtime
+  Description: Include functionality from the C run-time library (which must be installed already)
+  Default: False
+
+library
+  default-language: Haskell2010
+  build-depends:
+    -- GHC 8.0.2 to GHC 8.10.4
+    array >= 0.5.1 && < 0.6,
+    base >= 4.9.1 && < 4.16,
+    bytestring >= 0.10.8 && < 0.11,
+    containers >= 0.5.7 && < 0.7,
+    exceptions >= 0.8.3 && < 0.11,
+    ghc-prim >= 0.5.0 && < 0.7.1,
+    mtl >= 2.2.1 && < 2.3,
+    pretty >= 1.1.3 && < 1.2,
+    random >= 1.1 && < 1.3,
+    utf8-string >= 1.0.1.1 && < 1.1,
+    -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
+    transformers-compat >= 0.5.1.4 && < 0.7
+
+  if impl(ghc<8.0)
+    build-depends:
+      fail >= 4.9.0 && < 4.10
+
+  hs-source-dirs: src/runtime/haskell
 
   other-modules:
+    -- not really part of GF but I have changed the original binary library
+    -- and we have to keep the copy for now.
+    Data.Binary
+    Data.Binary.Put
+    Data.Binary.Get
+    Data.Binary.Builder
+    Data.Binary.IEEE754
+
+--ghc-options: -fwarn-unused-imports
+--if impl(ghc>=7.8)
+--  ghc-options: +RTS -A20M -RTS
+  -- ghc-prof-options: -fprof-auto
+
+  exposed-modules:
+    PGF
+    PGF.Internal
+    PGF.Haskell
+
+  other-modules:
+    PGF.Data
+    PGF.Macros
+    PGF.Binary
+    PGF.Optimize
+    PGF.Printer
+    PGF.CId
+    PGF.Expr
+    PGF.Generate
+    PGF.Linearize
+    PGF.Morphology
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Probabilistic
+    PGF.SortTop
+    PGF.Tree
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Forest
+    PGF.TrieMap
+    PGF.VisualizeTree
+    PGF.ByteCode
+    PGF.OldBinary
+    PGF.Utilities
+
+  if flag(c-runtime)
+    exposed-modules: PGF2
+    other-modules:
+      PGF2.FFI
+      PGF2.Expr
+      PGF2.Type
+      GF.Interactive2
+      GF.Command.Commands2
+    hs-source-dirs: src/runtime/haskell-bind
+    build-tools: hsc2hs
+    extra-libraries: pgf gu
+    c-sources: src/runtime/haskell-bind/utils.c
+    cc-options: -std=c99
+
+---- GF compiler as a library:
+
+  build-depends:
+    directory >= 1.3.0 && < 1.4,
+    filepath >= 1.4.1 && < 1.5,
+    haskeline >= 0.7.3 && < 0.9,
+    json >= 0.9.1 && < 0.11,
+    parallel >= 3.2.1.1 && < 3.3,
+    process >= 1.4.3 && < 1.7,
+    time >= 1.6.0 && < 1.10
+
+  hs-source-dirs: src/compiler
+  exposed-modules:
     GF
     GF.Support
     GF.Text.Pretty
     GF.Text.Lexing
     GF.Grammar.Canonical
 
-    GF.Main GF.Compiler GF.Interactive
+  other-modules:
+    GF.Main
+    GF.Compiler
+    GF.Interactive
 
-    GF.Compile GF.CompileInParallel GF.CompileOne  GF.Compile.GetGrammar
+    GF.Compile
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compile.GetGrammar
     GF.Grammar
 
-    GF.Data.Operations GF.Infra.Option GF.Infra.UseIO
+    GF.Data.Operations
+    GF.Infra.Option
+    GF.Infra.UseIO
 
     GF.Command.Abstract
     GF.Command.CommandInfo
@@ -110,20 +205,25 @@ executable gf
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
     GF.Compile.Compute.Concrete
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
     GF.Compile.GeneratePMCFG
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
-    GF.Compile.OptimizePGF
+    GF.Compile.Optimize
     GF.Compile.PGFtoHaskell
     GF.Compile.PGFtoJava
     GF.Haskell
     GF.Compile.ConcreteToHaskell
     GF.Compile.GrammarToCanonical
     GF.Grammar.CanonicalJSON
+    GF.Compile.PGFtoJS
     GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
     GF.Compile.ReadFiles
     GF.Compile.Rename
     GF.Compile.SubExOpt
@@ -190,20 +290,64 @@ executable gf
     GF.System.Directory
     GF.System.Process
     GF.System.Signal
-    GF.System.NoSignal
     GF.Text.Clitics
     GF.Text.Coding
-    GF.Text.Lexing
     GF.Text.Transliterations
     Paths_gf
-    
-    -- not really part of GF but I have changed the original binary library
-    -- and we have to keep the copy for now.
-    Data.Binary
-    Data.Binary.Put
-    Data.Binary.Get
-    Data.Binary.Builder
-    Data.Binary.IEEE754
+
+  if flag(c-runtime)
+    cpp-options: -DC_RUNTIME
+
+  if flag(server)
+    build-depends:
+      cgi >= 3001.3.0.2 && < 3001.6,
+      httpd-shed >= 0.4.0 && < 0.5,
+      network>=2.3 && <3.2
+    if flag(network-uri)
+      build-depends:
+        network-uri >= 2.6.1.0 && < 2.7,
+        network>=2.6 && <3.2
+    else
+      build-depends:
+        network >= 2.5 && <3.2
+
+    cpp-options: -DSERVER_MODE
+    other-modules:
+      GF.Server
+      PGFService
+      RunHTTP
+      SimpleEditor.Convert
+      SimpleEditor.JSON
+      SimpleEditor.Syntax
+      URLEncoding
+      CGI
+      CGIUtils
+      Cache
+      Fold
+      ExampleDemo
+      ExampleService
+    hs-source-dirs:
+      src/server
+      src/server/transfer
+      src/example-based
+
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+
+  if impl(ghc>=7.8)
+    build-tools:
+      happy>=1.19,
+      alex>=3.1
+--  ghc-options: +RTS -A20M -RTS
+  else
+    build-tools:
+      happy,
+      alex>=3
+
+  ghc-options: -fno-warn-tabs
 
   if os(windows)
     build-depends:
@@ -213,12 +357,50 @@ executable gf
       terminfo >=0.4.0 && < 0.5,
       unix >= 2.7.2 && < 2.8
 
+  if impl(ghc>=8.2)
+    ghc-options: -fhide-source-paths
+
+executable gf
+  hs-source-dirs: src/programs
+  main-is: gf-main.hs
+  default-language: Haskell2010
+  build-depends:
+    gf,
+    base
+  ghc-options: -threaded
+--ghc-options: -fwarn-unused-imports
+
+  if impl(ghc>=7.0)
+    ghc-options: -rtsopts -with-rtsopts=-I5
+    if impl(ghc<7.8)
+      ghc-options: -with-rtsopts=-K64M
+
+  -- ghc-prof-options: -auto-all
+
+  if impl(ghc>=8.2)
+    ghc-options: -fhide-source-paths
+
+-- executable pgf-shell
+-- --if !flag(c-runtime)
+--   buildable: False
+--   main-is: pgf-shell.hs
+--   hs-source-dirs: src/runtime/haskell-bind/examples
+--   build-depends:
+--     gf,
+--     base,
+--     containers,
+--     mtl,
+--     lifted-base
+--   default-language: Haskell2010
+--   if impl(ghc>=7.0)
+--     ghc-options: -rtsopts
+
 test-suite gf-tests
   type: exitcode-stdio-1.0
   main-is: run.hs
   hs-source-dirs: testsuite
   build-depends:
-    base >= 4.9.1 && < 4.15,
+    base >= 4.9.1 && < 4.16,
     Cabal >= 1.8,
     directory >= 1.3.0 && < 1.4,
     filepath >= 1.4.1 && < 1.5,

src/compiler/GF/Command/Abstract.hs

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

src/compiler/GF/Command/CommandInfo.hs

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

src/compiler/GF/Command/Commands.hs

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

src/compiler/GF/Command/Commands2.hs

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

src/compiler/GF/Command/CommonCommands.hs

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

src/compiler/GF/Command/Importing.hs

@@ -1,7 +1,7 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
-import PGF2
-import PGF2.Internal(unionPGF)
+import PGF
+import PGF.Internal(optimizePGF,unionPGF,msgUnionPGF)
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)
@@ -17,16 +17,14 @@ import GF.Data.ErrM
 
 import System.FilePath
 import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Control.Monad(foldM)
 
 -- import a grammar in an environment where it extends an existing grammar
-importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
-importGrammar pgf0 _    []    = return pgf0
+importGrammar :: PGF -> Options -> [FilePath] -> IO 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
+    ".cf"   -> importCF opts files getBNFCRules bnfc2cf
+    ".ebnf" -> importCF opts files getEBNFRules ebnf2cf
     ".gfm"  -> do
       ascss <- mapM readMulti files
       let cs = concatMap snd ascss
@@ -38,17 +36,14 @@ importGrammar pgf0 opts files =
         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
+      pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
+      ioUnionPGF pgf0 pgf2
     ext -> die $ "Unknown filename extension: " ++ show ext
 
-ioUnionPGF :: Maybe PGF -> PGF -> IO (Maybe PGF)
-ioUnionPGF 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)
+ioUnionPGF :: PGF -> PGF -> IO PGF
+ioUnionPGF one two = case msgUnionPGF one two of
+  (pgf, Just msg) -> putStrLn msg >> return pgf
+  (pgf,_)         -> return pgf
 
 importSource :: Options -> [FilePath] -> IO SourceGrammar
 importSource opts files = fmap (snd.snd) (batchCompile opts files)
@@ -61,6 +56,7 @@ importCF opts files get convert = impCF
       startCat <- case rules of
                     (Rule cat _ _ : _) -> return cat
                     _                  -> fail "empty CFG"
-      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
-      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
-      return pgf
+      let pgf = cf2pgf (last files) (mkCFG startCat Set.empty rules)
+      probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf
+      return $ setProbabilities probs 
+             $ if flag optOptimizePGF opts then optimizePGF pgf else pgf

src/compiler/GF/Command/Interpreter.hs

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

src/compiler/GF/Command/SourceCommands.hs

@@ -8,11 +8,9 @@ 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)
-import GF.Data.Str(sstr)
 import GF.Data.Operations (chunks,err,raise)
+import GF.Text.Pretty(render)
+import GF.Data.Str(sstr)
 
 import GF.Grammar hiding (Ident,isPrefixOf)
 import GF.Grammar.Analyse
@@ -20,8 +18,10 @@ 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.Compute.Concrete(normalForm,resourceValues)
 import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
+import GF.Infra.Dependencies(depGraph)
+import GF.Infra.CheckM(runCheck)
 
 import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
 import GF.Command.CommandInfo
@@ -162,11 +162,12 @@ sourceCommands = Map.fromList [
       do sgr <- getGrammar
          liftSIO (exec opts (toStrings ts) sgr)
 
-    compute_concrete opts ws sgr = fmap fst $ runCheck $
+    compute_concrete opts ws sgr =
       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))
+        Right t      -> return $ err pipeMessage
+                                     (fromString . showTerm sgr style q)
+                                 $ checkComputeTerm opts sgr t
       where
         (style,q) = pOpts TermPrintDefault Qualified opts
         s = unwords ws
@@ -199,16 +200,16 @@ sourceCommands = Map.fromList [
                 | otherwise = unwords $ map prTerm ops
           return $ fromString printed
 
-    show_operations os ts sgr = fmap fst $ runCheck $
+    show_operations os ts sgr =
       case greatestResource sgr of
-        Nothing -> checkError (pp "no source grammar in scope; did you import with -retain?")
+        Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?"
         Just mo -> do
           let greps = map valueString (listFlags "grep" os)
           let isRaw = isOpt "raw" os
           ops <- case ts of
              _:_ -> do
                let Right t = runP pExp (UTF8.fromString (unwords ts))
-               ty <- checkComputeTerm os sgr t
+               ty <- err error return $ checkComputeTerm os sgr t
                return $ allOpersTo sgr ty
              _   -> return $ allOpers sgr
           let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
@@ -253,12 +254,14 @@ sourceCommands = Map.fromList [
          return void
 
 checkComputeTerm os sgr t =
-  do mo <- maybe (checkError (pp "no source grammar in scope")) return $
+  do mo <- maybe (raise "no source grammar in scope") return $
            greatestResource sgr
-     t <- renameSourceTerm sgr mo t
-     (t,_) <- inferLType sgr [] t                                
+     ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
+                                inferLType sgr [] t
      let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-     fmap evalStr (normalForm sgr t)
+         t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
+         t2 = evalStr t1
+     checkPredefError t2
   where
     -- ** Try to compute pre{...} tokens in token sequences
     evalStr t =

src/compiler/GF/Command/TreeOperations.hs

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

src/compiler/GF/Compile.hs

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

src/compiler/GF/Compile/CFGtoPGF.hs

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

src/compiler/GF/Compile/CheckGrammar.hs

@@ -21,15 +21,15 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.CheckGrammar(checkModule) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
-import Prelude hiding ((<>))
 import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType)
+import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
 import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
-import GF.Compile.Compute.Concrete(normalForm)
+import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -54,7 +54,11 @@ checkModule opts cwd sgr mo@(m,mi) = do
                              checkCompleteGrammar opts cwd gr (a,abs) mo
           _            -> return mo
   infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo
-  foldM (foldM (checkInfo opts cwd sgr)) mo infoss
+  foldM updateCheckInfos mo infoss
+  where
+    updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
+      where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
+    update mo@(m,mi) (i,info) = (m,mi{jments=Map.insert i info (jments mi)})
 
 -- check if restricted inheritance modules are still coherent
 -- i.e. that the defs of remaining names don't depend on omitted names
@@ -116,7 +120,8 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
                                     return js
                    _ -> do
                      case mb_def of
-                       Ok def -> do linty <- linTypeOfType gr cm (L loc ty)
+                       Ok def -> do (cont,val) <- linTypeOfType gr cm ty
+                                    let linty = (snd (valCat ty),cont,val)
                                     return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
                        Bad _  -> do noLinOf c
                                     return js
@@ -135,8 +140,9 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
    checkCnc js (c,info) =
      case info of
        CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L loc ty)) _ _ _) ->
-                                        do linty <- linTypeOfType gr cm (L loc ty)
+                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
+                                        do (cont,val) <- linTypeOfType gr cm ty
+                                           let linty = (snd (valCat ty),cont,val)
                                            return $ Map.insert c (CncFun (Just linty) d mn mf) js
                              _       -> do checkWarn ("function" <+> c <+> "is not in abstract")
                                            return js
@@ -152,30 +158,37 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
 
        _ -> return $ Map.insert c info js
 
-checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> (Ident,Info) -> Check SourceModule
-checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
+
+-- | General Principle: only Just-values are checked.
+-- A May-value has always been checked in its origin module.
+checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
+checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
   checkReservedId c
   case info of
     AbsCat (Just (L loc cont)) ->
       mkCheck loc "the category" $
         checkContext gr cont
 
-    AbsFun (Just (L loc typ)) ma md moper -> do
+    AbsFun (Just (L loc typ0)) ma md moper -> do
+      typ <- compAbsTyp [] typ0   -- to calculate let definitions
       mkCheck loc "the type of function" $
         checkTyp gr typ
-      typ <- compAbsTyp [] typ   -- to calculate let definitions
       case md of
         Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
-                                          checkDef gr (fst sm,c) typ eq) eqs
+                                          checkDef gr (m,c) typ eq) eqs
         Nothing  -> return ()
-      update sm c (AbsFun (Just (L loc typ)) ma md moper)
+      return (AbsFun (Just (L loc typ)) ma md moper)
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
-                Just (L loc typ) -> chIn loc "linearization type of" $ do
-                                      (typ,_) <- checkLType gr [] typ typeType
-                                      typ  <- normalForm gr typ
-                                      return (Just (L loc typ))
+                Just (L loc typ) -> chIn loc "linearization type of" $
+                                     (if False --flag optNewComp opts
+                                        then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
+                                                typ  <- computeLType gr [] typ
+                                                return (Just (L loc typ))
+                                        else do (typ,_) <- checkLType gr [] typ typeType
+                                                typ  <- computeLType gr [] typ
+                                                return (Just (L loc typ)))
                 Nothing          -> return Nothing
       mdef <- case (mty,mdef) of
                 (Just (L _ typ),Just (L loc def)) ->
@@ -195,11 +208,11 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
-      update sm c (CncCat mty mdef mref mpr mpmcfg)
+      return (CncCat mty mdef mref mpr mpmcfg)
 
     CncFun mty mt mpr mpmcfg -> do
       mt <- case (mty,mt) of
-              (Just (_,cat,cont,val),Just (L loc trm)) ->
+              (Just (cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
                      (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
                      return (Just (L loc trm))
@@ -210,55 +223,55 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
                 _ -> return Nothing
-      update sm c (CncFun mty mt mpr mpmcfg)
+      return (CncFun mty mt mpr mpmcfg)
 
     ResOper pty pde -> do
       (pty', pde') <- case (pty,pde) of
          (Just (L loct ty), Just (L locd de)) -> do
-           ty'     <- chIn loct "operation" $ do
-                         (ty,_) <- checkLType gr [] ty typeType
-                         normalForm gr ty
+           ty'     <- chIn loct "operation" $
+                         (if False --flag optNewComp opts
+                            then CN.checkLType (CN.resourceValues opts gr) ty typeType >>= return . CN.normalForm (CN.resourceValues opts gr) (L loct c) . fst -- !!
+                            else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
            (de',_) <- chIn locd "operation" $
-                         checkLType gr [] de ty'
+                         (if False -- flag optNewComp opts
+                            then CN.checkLType (CN.resourceValues opts gr) de ty'
+                            else checkLType gr [] 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
+                          (if False -- flag optNewComp opts
+                            then CN.inferLType (CN.resourceValues opts gr) de
+                            else inferLType gr [] de)
            return (Just (L locd ty'), Just (L locd de'))
          (Just (L loct ty), Nothing) -> do
            chIn loct "operation" $
              checkError (pp "No definition given to the operation")
-      update sm c (ResOper pty' pde')
+      return (ResOper pty' pde')
 
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
       tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
-      tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
+      tysts0 <- lookupOverload gr (m,c)  -- check against inherited ones too
       tysts1 <- mapM (uncurry $ flip (checkLType gr []))
                   [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
       checkUniq $
         sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
-      update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
+      return (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do
-      (sm,cnt,ts) <- chIn loc "parameter type" $
-                        mkParamValues sm 0 [] pcs
-      update sm c (ResParam (Just (L loc pcs)) (Just (ts,cnt)))
+      ts <- chIn loc "parameter type" $
+              liftM concat $ mapM mkPar pcs
+      return (ResParam (Just (L loc pcs)) (Just ts))
 
-    _ ->  return sm
+    _ ->  return info
  where
-   gr = prependModule sgr sm
-   chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c)
+   gr = prependModule sgr (m,mo)
+   chIn loc cat = checkInModule cwd mo 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)
-     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)
+   mkPar (f,co) = do
+       vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+       return $ map (mkApp (QC (m,f))) vs
 
    checkUniq xss = case xss of
      x:y:xs
@@ -268,7 +281,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
      _ -> return ()
 
    mkCheck loc cat ss = case ss of
-     [] -> return sm
+     [] -> return info
      _ -> chIn loc cat $ checkError (vcat ss)
 
    compAbsTyp g t = case t of
@@ -281,9 +294,7 @@ 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  
-
-   update (mn,mi) c info = return (mn,mi{jments=Map.insert c info (jments mi)})
+     _ -> composOp (compAbsTyp g) t
 
 
 -- | for grammars obtained otherwise than by parsing ---- update!!
@@ -295,13 +306,12 @@ checkReservedId x =
 -- auxiliaries
 
 -- | linearization types and defaults
-linTypeOfType :: Grammar -> ModuleName -> L Type -> Check ([Ident],Ident,Context,Type)
-linTypeOfType cnc m (L loc typ) = do
-  let (ctxt,res_cat) = typeSkeleton typ
-  val <- lookLin res_cat
-  lin_args <- mapM mkLinArg (zip [0..] ctxt)
-  let (args,arg_cats) = unzip lin_args
-  return (arg_cats, snd res_cat, args, val)
+linTypeOfType :: Grammar -> ModuleName -> Type -> Check (Context,Type)
+linTypeOfType cnc m typ = do
+  let (cont,cat) = typeSkeleton typ
+  val  <- lookLin cat
+  args <- mapM mkLinArg (zip [0..] cont)
+  return (args, val)
  where
    mkLinArg (i,(n,mc@(m,cat))) = do
      val  <- lookLin mc
@@ -313,8 +323,8 @@ linTypeOfType cnc m (L loc typ) = do
                                       "with" $$
                                       nest 2 val)) $
                              plusRecType vars val
-     return ((Explicit,symb,rec),cat)
+     return (Explicit,symb,rec)
    lookLin (_,c) = checks [ --- rather: update with defLinType ?
-      lookupLincat cnc m c >>= normalForm cnc
+      lookupLincat cnc m c >>= computeLType cnc []
      ,return defLinType
      ]

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

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

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

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

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -1,7 +1,5 @@
 -- | 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
@@ -18,13 +16,13 @@ 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
-         ]
+concretes2haskell opts absname gr =
+  [(filename,render80 $ concrete2haskell opts abstr cncmod)
+     | let Grammar abstr cncs = grammar2canonical opts absname gr,
+       cncmod<-cncs,
+       let ModId name = concName cncmod
+           filename = showRawIdent name ++ ".hs" :: FilePath
+  ]
 
 -- | Generate Haskell code for the given concrete module.
 -- The only options that make a difference are
@@ -183,9 +181,9 @@ concrete2haskell opts
 
         ppL l =
           case l of
-            LFlt x -> pure (lit x)
-            LInt n -> pure (lit n)
-            LStr s -> pure (token s)
+            FloatConstant x -> pure (lit x)
+            IntConstant n -> pure (lit n)
+            StrConstant s -> pure (token s)
 
         pId p@(ParamId s) =
           if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack

src/compiler/GF/Compile/ExampleBased.hs

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

src/compiler/GF/Compile/Export.hs

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

src/compiler/GF/Compile/GenerateBC.hs

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

src/compiler/GF/Compile/GeneratePMCFG.hs

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

src/compiler/GF/Compile/GetGrammar.hs

@@ -50,13 +50,20 @@ getSourceModule opts file0 =
        Right (i,mi0) ->
          do liftIO $ removeTemp tmp
             let mi =mi0 {mflags=mflags mi0 `addOptions` opts, msrc=file0}
-            case renameEncoding `fmap` flag optEncoding (mflags mi0) of
-              Just coding' -> 
-                when (coding/=coding') $
+                optCoding' = renameEncoding `fmap` flag optEncoding (mflags mi0)
+            case (optCoding,optCoding') of
+              {-
+              (Nothing,Nothing) ->
+                  unless (BS.all isAscii raw) $
+                    ePutStrLn $ file0++":\n    Warning: default encoding has changed from Latin-1 to UTF-8"
+              -}
+              (_,Just coding') -> 
+                  when (coding/=coding') $
                   raise $ "Encoding mismatch: "++coding++" /= "++coding'
                 where coding = maybe defaultEncoding renameEncoding optCoding
               _ -> return ()
-            return (i,mi)
+          --liftIO $ transcodeModule' (i,mi) -- old lexer
+            return (i,mi) -- new lexer
 
 getBNFCRules :: Options -> FilePath -> IOE [BNFCRule]
 getBNFCRules opts fpath = do

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -15,12 +15,12 @@ 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.Compile.Compute.Predef(predef)
+import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
 import GF.Infra.Option(Options,optionsPGF)
-import GF.Infra.CheckM
-import PGF2(Literal(..))
-import GF.Compile.Compute.Concrete(normalForm)
+import PGF.Internal(Literal(..))
+import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
 import System.FilePath ((</>), (<.>))
 import qualified Debug.Trace as T
@@ -28,16 +28,15 @@ 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))
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
+grammar2canonical opts absname gr =
+   Grammar (abstract2canonical absname gr)
+           (map snd (concretes2canonical opts absname gr))
 
 -- | Generate Canonical code for the named abstract syntax
-abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
+abstract2canonical :: ModuleName -> G.Grammar -> Abstract
 abstract2canonical absname gr =
-  return (Abstract (modId absname) (convFlags gr absname) cats funs)
+    Abstract (modId absname) (convFlags gr absname) cats funs
   where
     cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
 
@@ -50,7 +49,7 @@ abstract2canonical absname gr =
     convHypo (bt,name,t) =
       case typeForm t of
         ([],(_,cat),[]) -> gId cat -- !!
-        tf -> error ("abstract2canonical convHypo: " ++ show tf)
+        tf -> error $ "abstract2canonical convHypo: " ++ show tf
 
     convType t =
       case typeForm t of
@@ -63,24 +62,27 @@ abstract2canonical absname gr =
 
 -- | 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 :: Options -> ModuleName -> G.Grammar -> [(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
-        ]
+  [(cncname,concrete2canonical gr cenv absname cnc cncmod)
+     | let cenv = resourceValues opts gr,
+       cnc<-allConcretes gr absname,
+       let cncname = "canonical" </> render cnc <.> "gf"
+           Ok cncmod = lookupModule gr cnc
+  ]
 
 -- | Generate Canonical GF for the given concrete module.
-concrete2canonical :: G.Grammar -> 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])
+concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
+concrete2canonical gr cenv absname cnc modinfo =
+  Concrete (modId cnc) (modId absname) (convFlags gr cnc)
+      (neededParamTypes S.empty (params defs))
+      [lincat | (_,Left lincat) <- defs]
+      [lin | (_,Right lin) <- defs]
   where
+    defs = concatMap (toCanonical gr absname cenv) .
+           M.toList $
+           jments modinfo
+
     params = S.toList . S.unions . map fst
 
     neededParamTypes have [] = []
@@ -90,25 +92,32 @@ concrete2canonical gr absname cnc modinfo = do
         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) =
+toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
+toCanonical gr absname cenv (name,jment) =
   case jment of
-    CncCat (Just (L loc typ)) _ _ pprn _ -> 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)))]
+    CncCat (Just (L loc typ)) _ _ pprn _ ->
+        [(pts,Left (LincatDef (gId name) (convType ntyp)))]
+      where
+        pts = paramTypes gr ntyp
+        ntyp = nf loc typ
+    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
+        [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
+      where
+        tts = tableTypes gr [e']
+
+        e' = cleanupRecordFields lincat $
+             unAbs (length params) $
+             nf loc (mkAbs params (mkApp def (map Vr args)))
+        params = [(b,x)|(b,x,_)<-ctx]
+        args = map snd params
+
     AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
-                     Ok (m,jment) -> toCanonical gr absname (name,jment)
-                     _ -> return []
-    _ -> return []
+                     Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
+                     _ -> []
+    _ -> []
   where
+    nf loc = normalForm cenv (L loc name)
+
     unAbs 0 t = t
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t
@@ -184,18 +193,18 @@ convert' gr vs = ppT
         Cn x -> VarValue (gId x) -- hmm
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
-        EInt n -> LiteralValue (LInt n)
+        EInt n -> LiteralValue (IntConstant n)
         Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
         QC (m,n) -> ParamConstant (Param (gQId m n) [])
-        K s -> LiteralValue (LStr s)
-        Empty -> LiteralValue (LStr "")
+        K s -> LiteralValue (StrConstant s)
+        Empty -> LiteralValue (StrConstant "")
         FV ts -> VariantValue (map ppT ts)
         Alts t' vs -> alts vs (ppT t')
         _ -> error $ "convert' ppT: " ++ show t
 
     ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
-    ppPredef n = error "TODO: ppPredef" {-
+    ppPredef n =
       case predef n of
         Ok BIND       -> p "BIND"
         Ok SOFT_BIND  -> p "SOFT_BIND"
@@ -205,7 +214,7 @@ convert' gr vs = ppT
         _ -> 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))
@@ -234,12 +243,12 @@ convert' gr vs = ppT
         pre (K s) = [s]
         pre Empty = [""]  -- Empty == K ""
         pre (Strs ts) = concatMap pre ts
-        pre (EPatt _ _ p) = pat p
+        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 (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)
@@ -256,8 +265,8 @@ convert' gr vs = ppT
 concatValue :: LinValue -> LinValue -> LinValue
 concatValue v1 v2 =
   case (v1,v2) of
-    (LiteralValue (LStr ""),_) -> v2
-    (_,LiteralValue (LStr "")) -> v1
+    (LiteralValue (StrConstant ""),_) -> v2
+    (_,LiteralValue (StrConstant "")) -> v1
     _ -> ConcatValue v1 v2
 
 -- | Smart constructor for projections
@@ -420,5 +429,11 @@ unqual n = Unqual (ident2raw n)
 
 convFlags :: G.Grammar -> ModuleName -> Flags
 convFlags gr mn =
-  Flags [(rawIdentS n,v) |
+  Flags [(rawIdentS n,convLit v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
+  where
+    convLit l =
+      case l of
+        LStr s -> Str s
+        LInt i -> C.Int i
+        LFlt d -> Flt d

src/compiler/GF/Compile/GrammarToPGF.hs

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

src/compiler/GF/Compile/Optimize.hs

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

src/compiler/GF/Compile/OptimizePGF.hs

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

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -16,14 +16,13 @@
 
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
-import PGF2
-import PGF2.Internal
+import PGF(showCId)
+import PGF.Internal
 
 import GF.Data.Operations
 import GF.Infra.Option
 
 import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
-import Data.Maybe(mapMaybe)
 import qualified Data.Map as Map
 
 type Prefix = String -> String
@@ -259,7 +258,7 @@ fInstance gId lexical m (cat,rules) =
     then "    " ++ gId cat ++ " (fgs t) where\n     fgs t = case unApp t of"
     else "    case unApp t of") ++++
   unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
-  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "i" else "") ++++
+  (if lexical cat then "      Just (i,[]) -> " ++ lexicalConstructor cat +++ "(showCId i)" else "") ++++
   "      _ -> error (\"no" +++ cat ++ " \" ++ show t)"
    where
     isList = isListCat (cat,rules)
@@ -280,22 +279,19 @@ fInstance gId lexical m (cat,rules) =
 
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr = 
-  (abstractName gr,
-   let fs = 
-         [(c, [(f, cs) | (f, cs,_) <- fs]) | 
-                                        fs@((_, _,c):_) <- fns]
-   in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
+hSkeleton gr =
+  (showCId (absname gr),
+   let fs =
+         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
+                                        fs@((_, (_,c)):_) <- fns]
+   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
-   cts = categories gr
-   fns = groupBy valtypg (sortBy valtyps (mapMaybe jty (functions gr)))
-   valtyps (_,_,x) (_,_,y) = compare x y
-   valtypg (_,_,x) (_,_,y) = x == y
-   jty f = case functionType gr f of
-             Just ty -> let (hypos,valcat,_) = unType ty
-                        in Just (f,[argcat | (_,_,ty) <- hypos, let (_,argcat,_) = unType ty],valcat)
-             Nothing -> Nothing
+   cts = Map.keys (cats (abstract gr))
+   fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
+   valtyps (_, (_,x)) (_, (_,y)) = compare x y
+   valtypg (_, (_,x)) (_, (_,y)) = x == y
+   jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
 {-
 updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
 updateSkeleton cat skel rule =

src/compiler/GF/Compile/PGFtoJS.hs

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

src/compiler/GF/Compile/PGFtoJSON.hs

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

src/compiler/GF/Compile/PGFtoJava.hs

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

src/compiler/GF/Compile/PGFtoProlog.hs

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

src/compiler/GF/Compile/PGFtoPython.hs

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

src/compiler/GF/Compile/Rename.hs

@@ -130,8 +130,8 @@ renameIdentTerm' env@(act,imps) t0 =
 info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
 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
+  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
@@ -168,9 +168,9 @@ renameInfo cwd status (m,mi) i info =
     ResParam (Just pp) m -> do
       pp' <- renLoc (mapM (renParam status)) pp
       return (ResParam (Just pp') m)
-    ResValue t i -> do
+    ResValue t -> do
       t <- renLoc (renameTerm status []) t
-      return (ResValue t i)
+      return (ResValue t)
     CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
     CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty)         (renTerm mtr) (renTerm mpr) (return mpmcfg)
     _ -> return info
@@ -237,9 +237,9 @@ renameTerm env vars = ren vars where
                             , checkError ("unknown qualified constant" <+> trm)
                             ]
 
-    EPatt minp maxp p -> do
+    EPatt p -> do
       (p',_) <- renpatt p
-      return $ EPatt minp maxp p'
+      return $ EPatt p'
 
     _ -> composOp (ren vs) trm
 
@@ -306,14 +306,14 @@ renamePattern env patt =
         (q',ws) <- renp q
         return (PAlt p' q', vs ++ ws)
 
-      PSeq minp maxp p minq maxq q -> do
+      PSeq p q -> do
         (p',vs) <- renp p
         (q',ws) <- renp q
-        return (PSeq minp maxp p' minq maxq q', vs ++ ws)
+        return (PSeq p' q', vs ++ ws)
 
-      PRep minp maxp p -> do
+      PRep p -> do
         (p',vs) <- renp p
-        return (PRep minp maxp p', vs)
+        return (PRep p', vs)
 
       PNeg p -> do
         (p',vs) <- renp p

src/compiler/GF/Compile/Tags.hs

@@ -31,7 +31,7 @@ getLocalTags x (m,mi) =
     getLocations (AbsFun mb_type _ mb_eqs _)    = maybe (ltype "fun")        mb_type ++
                                                   maybe (list (loc "def"))   mb_eqs  
     getLocations (ResParam mb_params _)         = maybe (loc "param")        mb_params
-    getLocations (ResValue mb_type _)           = ltype "param-value"          mb_type
+    getLocations (ResValue mb_type)             = ltype "param-value"          mb_type
     getLocations (ResOper  mb_type mb_def)      = maybe (ltype "oper-type")  mb_type ++
                                                   maybe (loc "oper-def")     mb_def
     getLocations (ResOverload _ defs)           = list (\(x,y) -> ltype "overload-type" x ++ 

src/compiler/GF/Compile/ToAPI.hs

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

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

@@ -13,7 +13,6 @@ 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
 
@@ -265,10 +264,9 @@ inferLType gr g trm = case trm of
    EPattType ty -> do
      ty' <- justCheck g ty typeType
      return (EPattType ty',typeType)
-   EPatt _ _ p -> do
+   EPatt p -> do
      ty <- inferPatt p
-     let (minp,maxp,p') = measurePatt gr p
-     return (EPatt minp maxp p', EPattType ty)
+     return (trm, EPattType ty)
 
    ELin c trm -> do
      (trm',ty) <- inferLType gr g trm
@@ -292,7 +290,7 @@ inferLType gr g trm = case trm of
    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
+     (_,val) <- inferLType gr (reverse cont ++ g) term
      return (arg,val)
    isConstPatt p = case p of
      PC _ ps -> True --- all isConstPatt ps
@@ -304,9 +302,9 @@ inferLType gr g trm = case trm of
      PFloat _ -> True
      PChar -> True
      PChars _ -> True
-     PSeq _ _ p _ _ q -> isConstPatt p && isConstPatt q
+     PSeq p q -> isConstPatt p && isConstPatt q
      PAlt p q -> isConstPatt p && isConstPatt q
-     PRep _ _ p -> isConstPatt p
+     PRep p -> isConstPatt p
      PNeg p -> isConstPatt p
      PAs _ p -> isConstPatt p
      _ -> False
@@ -316,44 +314,12 @@ inferLType gr g trm = case trm of
      PAs _ p  -> inferPatt p
      PNeg p   -> inferPatt p
      PAlt p q -> checks [inferPatt p, inferPatt q]
-     PSeq _ _ _ _ _ _ -> return $ typeStr
-     PRep _ _ _ -> return $ typeStr
+     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))
@@ -630,8 +596,7 @@ checkLType gr g trm typ0 = do
    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')
+     return (p,t')
 
 pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
 pattContext env g typ p = case p of
@@ -668,11 +633,11 @@ pattContext env g typ p = case p of
        fsep pts <+>
        "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
     return g1 -- must be g1 == g2
-  PSeq _ _ p _ _ q -> do
+  PSeq p q -> do
     g1 <- pattContext env g typ p
     g2 <- pattContext env g typ q
     return $ g1 ++ g2
-  PRep _ _ p' -> noBind typeStr p'
+  PRep p' -> noBind typeStr p'
   PNeg p' -> noBind typ p'
 
   _ -> return [] ---- check types!

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

@@ -11,6 +11,7 @@ import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
 import GF.Compile.Compute.Concrete
+import GF.Compile.Compute.Predef(predef,predefName)
 import GF.Infra.CheckM
 import GF.Data.Operations
 import Control.Applicative(Applicative(..))
@@ -21,20 +22,20 @@ 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
+checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type)
+checkLType ge t ty = runTcM $ do
   vty <- liftErr (eval ge [] ty)
   (t,_) <- tcRho ge [] t (Just vty)
   t <- zonkTerm t
-  return (t,ty) -}
+  return (t,ty)
 
-inferLType :: Grammar -> Term -> Check (Term, Type)
-inferLType ge t = error "TODO: inferLType" {- runTcM $ do
+inferLType :: GlobalEnv -> Term -> Check (Term, Type)
+inferLType ge t = runTcM $ do
   (t,ty) <- inferSigma ge [] t
   t  <- zonkTerm t
   ty <- zonkTerm =<< tc_value2term (geLoc ge) [] ty
-  return (t,ty) -}
-{-
+  return (t,ty)
+
 inferSigma :: GlobalEnv -> Scope -> Term -> TcM (Term,Sigma)
 inferSigma ge scope t = do                                      -- GEN1
   (t,ty) <- tcRho ge scope t Nothing
@@ -317,7 +318,7 @@ tcPatt ge scope (PString s) ty0 = do
 tcPatt ge scope PChar ty0 = do
   unify ge scope ty0 vtypeStr
   return scope
-tcPatt ge scope (PSeq _ _ p1 _ _ p2) ty0 = do
+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
@@ -799,4 +800,3 @@ runTcA g f = TcM (\ms msgs -> case f 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

@@ -8,7 +8,7 @@ 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
+                    Just (ResValue (L _ ty))         -> Just ty
                     _                                -> Nothing
 
 primitives = Map.fromList
@@ -16,9 +16,9 @@ primitives = Map.fromList
   , (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)
+  , (cPBool    , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
+  , (cPTrue    , ResValue (noLoc typePBool))
+  , (cPFalse   , ResValue (noLoc typePBool))
   , (cError    , fun [typeStr] typeError)  -- non-can. of empty set
   , (cLength   , fun [typeTok] typeInt)
   , (cDrop     , fun [typeInt,typeTok] typeTok)

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

@@ -35,7 +35,7 @@ data AExp =
      AVr   Ident Val
    | ACn   QIdent Val
    | AType
-   | AInt  Integer
+   | AInt  Int
    | AFloat Double
    | AStr  String
    | AMeta MetaId Val

src/compiler/GF/Compile/Update.hs

@@ -78,7 +78,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_ env_ js_)) =
   checkInModule cwd mi NoLoc empty $ do
 
 ----  deps <- moduleDeps ms
@@ -115,7 +115,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 +131,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_ env_ js1
 
   return (i,mi')
 
@@ -168,7 +168,7 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
     indirInfo :: ModuleName -> Info -> Info
     indirInfo n info = AnyInd b n' where
       (b,n') = case info of
-        ResValue _ _ -> (True,n)
+        ResValue _ -> (True,n)
         ResParam _ _ -> (True,n)
         AbsFun _ _ Nothing _ -> (True,n)
         AnyInd b k -> (b,k)
@@ -179,7 +179,7 @@ globalizeLoc fpath i =
     AbsCat mc             -> AbsCat (fmap gl mc)
     AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
     ResParam mt mv        -> ResParam (fmap gl mt) mv
-    ResValue t i          -> ResValue (gl t) i
+    ResValue t            -> ResValue (gl t)
     ResOper mt m          -> ResOper (fmap gl mt) (fmap gl m)
     ResOverload ms os     -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
     CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
@@ -201,9 +201,9 @@ unifyAnyInfo m i j = case (i,j) of
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
-  (ResValue (L l1 t1) i1, ResValue (L l2 t2) i2)
-      | t1==t2 && i1 == i2 -> return (ResValue (L l1 t1) i1)
-      | otherwise          -> fail ""
+  (ResValue (L l1 t1), ResValue (L l2 t2))
+      | t1==t2    -> return (ResValue (L l1 t1))
+      | otherwise -> fail ""
   (_, ResOverload ms t) | elem m ms ->
     return $ ResOverload ms t
   (ResOper mt1 m1, ResOper mt2 m2) ->

src/compiler/GF/CompileInParallel.hs

@@ -1,6 +1,6 @@
 -- | Parallel grammar compilation
 module GF.CompileInParallel(parallelBatchCompile) where
-import Prelude hiding (catch,(<>))
+import Prelude hiding (catch,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import Control.Monad(join,ap,when,unless)
 import Control.Applicative
 import GF.Infra.Concurrency
@@ -36,8 +36,11 @@ import qualified Control.Monad.Fail as Fail
 parallelBatchCompile jobs opts rootfiles0 =
   do setJobs jobs
      rootfiles <- mapM canonical rootfiles0
-     lib_dir  <- canonical =<< getLibraryDirectory opts
-     filepaths <- mapM (getPathFromFile lib_dir opts) rootfiles
+     lib_dirs1 <- getLibraryDirectory opts
+     lib_dirs2 <- mapM canonical lib_dirs1
+     let lib_dir = head lib_dirs2
+     when (length lib_dirs2 >1) $ ePutStrLn ("GF_LIB_PATH defines more than one directory; using the first, " ++ show lib_dir)
+     filepaths <- mapM (getPathFromFile [lib_dir] opts) rootfiles
      let groups = groupFiles lib_dir filepaths
          n = length groups
      when (n>1) $ ePutStrLn "Grammar mixes present and alltenses, dividing modules into two groups"

src/compiler/GF/CompileOne.hs

@@ -8,6 +8,7 @@ module GF.CompileOne(-- ** Compiling a single module
 import GF.Compile.GetGrammar(getSourceModule)
 import GF.Compile.Rename(renameModule)
 import GF.Compile.CheckGrammar(checkModule)
+import GF.Compile.Optimize(optimizeModule)
 import GF.Compile.SubExOpt(subexpModule,unsubexpModule)
 import GF.Compile.GeneratePMCFG(generatePMCFG)
 import GF.Compile.Update(extendModule,rebuildModule)
@@ -106,9 +107,10 @@ compileSourceModule opts cwd mb_gfFile gr =
 
     -- Apply to complete modules when not generating tags
     backend mo3 =
-      do if isModCnc (snd mo3) && flag optPMCFG opts
-          then runPassI "generating PMCFG" $ fmap fst $ runCheck' opts (generatePMCFG opts cwd gr mo3)
-          else runPassI "" $ return mo3
+      do mo4 <- runPassE Optimize "optimizing" $ optimizeModule opts gr mo3
+         if isModCnc (snd mo4) && flag optPMCFG opts
+          then runPassI "generating PMCFG" $ generatePMCFG opts gr mb_gfFile mo4
+          else runPassI "" $ return mo4
 
     ifComplete yes mo@(_,mi) =
       if isCompleteModule mi then yes mo else return mo
@@ -126,6 +128,7 @@ compileSourceModule opts cwd mb_gfFile gr =
 
     -- * Running a compiler pass, with impedance matching
     runPass = runPass' fst fst snd (liftErr . runCheck' opts)
+    runPassE = runPass2e liftErr id
     runPassI = runPass2e id id Canon
     runPass2e lift dump = runPass' id dump (const "") lift
 

src/compiler/GF/Compiler.hs

@@ -1,7 +1,8 @@
-module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
 
-import PGF2
-import PGF2.Internal(unionPGF,writeConcr)
+import PGF
+import PGF.Internal(concretes,optimizePGF,unionPGF)
+import PGF.Internal(putSplitAbs,encodeFile,runPut)
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -15,7 +16,6 @@ import GF.Grammar.CFG
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
 import GF.Infra.Option
-import GF.Infra.CheckM
 import GF.Data.ErrM
 import GF.System.Directory
 import GF.Text.Pretty(render,render80)
@@ -68,25 +68,22 @@ compileSourceFiles opts fs =
       where
         ofmts = flag optOutputFormats opts
 
-    cnc2haskell (cnc,gr) = do
-      (res,_) <- runCheck (concretes2haskell opts (srcAbsName gr cnc) gr)
-      mapM_ writeExport res
+    cnc2haskell (cnc,gr) =
+      do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr
 
-    abs2canonical (cnc,gr) = do
-      (canAbs,_) <- runCheck (abstract2canonical absname gr)
-      writeExport ("canonical/"++render absname++".gf",render80 canAbs)
+    abs2canonical (cnc,gr) =
+        writeExport ("canonical/"++render absname++".gf",render80 canAbs)
       where
         absname = srcAbsName gr cnc
+        canAbs = abstract2canonical absname gr
 
-    cnc2canonical (cnc,gr) = do
-      (res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
-      mapM_ (writeExport.fmap render80) res
+    cnc2canonical (cnc,gr) =
+      mapM_ (writeExport.fmap render80) $
+            concretes2canonical opts (srcAbsName gr cnc) gr
 
-    grammar2json (cnc,gr) = do
-      (gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
-      return (encodeJSON (render absname ++ ".json") gr_canon)
-      where
-        absname = srcAbsName gr cnc
+    grammar2json (cnc,gr) = encodeJSON (render absname ++ ".json") gr_canon
+      where absname = srcAbsName gr cnc
+            gr_canon = grammar2canonical opts absname gr
 
     writeExport (path,s) = writing opts path $ writeUTF8File path s
 
@@ -95,7 +92,7 @@ compileSourceFiles opts fs =
 -- in the 'Options') from the output of 'parallelBatchCompile'.
 -- If a @.pgf@ file by the same name already exists and it is newer than the
 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
--- recreated. Calls 'writeGrammar' and 'writeOutputs'.
+-- recreated. Calls 'writePGF' and 'writeOutputs'.
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -105,8 +102,10 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
        if t_pgf >= Just t_src
          then putIfVerb opts $ pgfFile ++ " is up-to-date."
          else do pgfs <- mapM (link opts) cnc_grs
-                 let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
-                 writeGrammar opts pgf
+                 let pgf0 = foldl1 unionPGF pgfs
+                 probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf0
+                 let pgf = setProbabilities probs pgf0
+                 writePGF opts pgf
                  writeOutputs opts pgf
 
 compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -116,11 +115,12 @@ compileCFFiles opts fs = do
   startCat <- case rules of
                 (Rule cat _ _ : _) -> return cat
                 _                  -> fail "empty CFG"
-  probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
-  let pgf = cf2pgf opts (last fs) (mkCFG startCat Set.empty rules) probs
+  let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
   unless (flag optStopAfterPhase opts == Compile) $
-     do writeGrammar opts pgf
-        writeOutputs opts pgf
+     do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
+        let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
+        writePGF opts pgf'
+        writeOutputs opts pgf'
 
 unionPGFFiles :: Options -> [FilePath] -> IOE ()
 unionPGFFiles opts fs =
@@ -138,11 +138,14 @@ unionPGFFiles opts fs =
 
     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")
+         let pgf0 = foldl1 unionPGF pgfs
+             pgf1 = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
+         probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf1)
+         let pgf  = setProbabilities probs pgf1
+             pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
          if pgfFile `elem` fs
            then putStrLnE $ "Refusing to overwrite " ++ pgfFile
-           else writeGrammar opts pgf
+           else writePGF opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -159,24 +162,21 @@ writeOutputs opts pgf = do
 -- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
 -- 'link') to a @.pgf@ file.
 -- A split PGF file is output if the @-split-pgf@ option is used.
-writeGrammar :: Options -> PGF -> IOE ()
-writeGrammar opts pgf =
-  if fst (flag optLinkTargets opts)
-    then if flag optSplitPGF opts
-           then writeSplitPGF
-           else writeNormalPGF
-    else return ()
+writePGF :: Options -> PGF -> IOE ()
+writePGF opts pgf =
+    if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
   where
     writeNormalPGF =
        do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-          writing opts outfile (writePGF outfile pgf)
+          writing opts outfile $ encodeFile outfile pgf
 
     writeSplitPGF =
       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-         writing opts outfile $ writePGF outfile pgf
-         forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do
-           let outfile = outputPath opts (concrname <.> "pgf_c")
-           writing opts outfile (writeConcr outfile concr)
+         writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
+                                --encodeFile_ outfile (putSplitAbs pgf)
+         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
+           let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
+           writing opts outfile $ encodeFile outfile cnc
 
 
 writeOutput :: Options -> FilePath-> String -> IOE ()
@@ -186,7 +186,7 @@ writeOutput opts file str = writing opts path $ writeUTF8File path str
 -- * Useful helper functions
 
 grammarName :: Options -> PGF -> String
-grammarName opts pgf = grammarName' opts (abstractName pgf)
+grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
 grammarName' opts abs = fromMaybe abs (flag optName opts)
 
 outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)

src/compiler/GF/Grammar/Analyse.hs

@@ -29,7 +29,7 @@ stripInfo i = case i of
   AbsCat _ -> i
   AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
   ResParam mp mt -> ResParam mp Nothing
-  ResValue lt _ -> i ----
+  ResValue lt -> i ----
   ResOper mt md -> ResOper mt Nothing
   ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
   CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
@@ -108,7 +108,7 @@ sizeInfo i = case i of
     sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
   ResParam mp mt -> 
     1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
-  ResValue _ _ -> 0
+  ResValue lt -> 0
   ResOper mt md -> 1 + msize mt + msize md
   ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
   CncCat mty _ _ _ _ -> 1 + msize mty   -- ignoring lindef, linref and printname

src/compiler/GF/Grammar/BNFC.hs

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

src/compiler/GF/Grammar/Binary.hs

@@ -10,9 +10,9 @@
 module GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader,decodeModule,encodeModule) where
 
 import Prelude hiding (catch)
-import Control.Monad
 import Control.Exception(catch,ErrorCall(..),throwIO)
-import Data.Binary
+
+import PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
 import qualified Data.Map as Map(empty)
 import qualified Data.ByteString.Char8 as BS
 
@@ -22,11 +22,11 @@ import GF.Infra.Option
 import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
-import PGF2(Literal(..))
-import PGF2.Transactions(Symbol(..))
+import PGF() -- Binary instances
+import PGF.Internal(Literal(..))
 
 -- Please change this every time when the GFO format is changed
-gfoVersion = "GF05"
+gfoVersion = "GF04"
 
 instance Binary Ident where
   put id = put (ident2utf8 id)
@@ -44,9 +44,9 @@ instance Binary Grammar where
   get = fmap mGrammar get
 
 instance Binary ModuleInfo where
-  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,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,19 +103,24 @@ 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 Production where
+  put (Production res funid args) = put (res,funid,args)
+  get = do res   <- get
+           funid <- get
+           args  <- get
+           return (Production res funid args)
 
-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 PMCFG where
+  put (PMCFG prods funs) = put (prods,funs)
+  get = do prods <- get
+           funs  <- get
+           return (PMCFG prods funs)
 
 instance Binary Info where
   put (AbsCat x)       = putWord8 0 >> put x
   put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z)
   put (ResParam x y)   = putWord8 2 >> put (x,y)
-  put (ResValue x y)   = putWord8 3 >> put (x,y)
+  put (ResValue x)     = putWord8 3 >> put x
   put (ResOper x y)    = putWord8 4 >> put (x,y)
   put (ResOverload x y)= putWord8 5 >> put (x,y)
   put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
@@ -126,7 +131,7 @@ instance Binary Info where
              0 -> get >>= \x         -> return (AbsCat x)
              1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z)
              2 -> get >>= \(x,y)     -> return (ResParam x y)
-             3 -> get >>= \(x,y)     -> return (ResValue x y)
+             3 -> get >>= \x         -> return (ResValue x)
              4 -> get >>= \(x,y)     -> return (ResOper x y)
              5 -> get >>= \(x,y)     -> return (ResOverload x y)
              6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)
@@ -177,13 +182,14 @@ instance Binary Term where
   put (QC x)        = putWord8 25 >> put x
   put (C x y)       = putWord8 26 >> put (x,y)
   put (Glue x y)    = putWord8 27 >> put (x,y)
-  put (EPatt x y z) = putWord8 28 >> put (x,y,z)
+  put (EPatt x)     = putWord8 28 >> put x
   put (EPattType x) = putWord8 29 >> put x
   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 (Error x)     = putWord8 35 >> put x
 
   get = do tag <- getWord8
            case tag of
@@ -215,13 +221,14 @@ instance Binary Term where
              25 -> get >>= \x       -> return (QC x)
              26 -> get >>= \(x,y)   -> return (C x y)
              27 -> get >>= \(x,y)   -> return (Glue x y)
-             28 -> get >>= \(x,y,z) -> return (EPatt x y z)
+             28 -> get >>= \x       -> return (EPatt x)
              29 -> get >>= \x       -> return (EPattType x)
              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)
+             35 -> get >>= \x       -> return (Error x)
              _  -> decodingError
 
 instance Binary Patt where
@@ -237,8 +244,8 @@ instance Binary Patt where
   put (PAs  x y)   = putWord8 10 >> put (x,y)
   put (PNeg x)     = putWord8 11 >> put x
   put (PAlt x y)   = putWord8 12 >> put (x,y)
-  put (PSeq minx maxx x miny maxy y)   = putWord8 13 >> put (minx,maxx,x,miny,maxy,y)
-  put (PRep minx maxx x)= putWord8 14 >> put (minx,maxx,x)
+  put (PSeq x y)   = putWord8 13 >> put (x,y)
+  put (PRep x)     = putWord8 14 >> put x
   put (PChar)      = putWord8 15
   put (PChars x)   = putWord8 16 >> put x
   put (PMacro x)   = putWord8 17 >> put x
@@ -259,8 +266,8 @@ instance Binary Patt where
              10 -> get >>= \(x,y)   -> return (PAs  x y)
              11 -> get >>= \x       -> return (PNeg x)
              12 -> get >>= \(x,y)   -> return (PAlt x y)
-             13 -> get >>= \(minx,maxx,x,miny,maxy,y) -> return (PSeq minx maxx x miny maxy y)
-             14 -> get >>= \(minx,maxx,x)-> return (PRep minx maxx x)
+             13 -> get >>= \(x,y)   -> return (PSeq x y)
+             14 -> get >>= \x       -> return (PRep x)
              15 ->                     return (PChar)
              16 -> get >>= \x       -> return (PChars x)
              17 -> get >>= \x       -> return (PMacro x)
@@ -291,53 +298,6 @@ instance Binary Label where
              1 -> fmap LVar   get
              _ -> decodingError
 
-instance Binary BindType where
-  put Explicit = putWord8 0
-  put Implicit = putWord8 1
-  get = do tag <- getWord8
-           case tag of
-             0 -> return Explicit
-             1 -> return Implicit
-             _ -> decodingError
-
-instance Binary Literal where
-  put (LStr s) = putWord8 0 >> put s
-  put (LInt i) = putWord8 1 >> put i
-  put (LFlt d) = putWord8 2 >> put d
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM  LStr get
-             1 -> liftM  LInt get
-             2 -> liftM  LFlt get
-             _ -> decodingError
-
-instance Binary Symbol where
-  put (SymCat d r rs)    = putWord8 0 >> put (d,r,rs)
-  put (SymLit n l)       = putWord8 1 >> put (n,l)
-  put (SymVar n l)       = putWord8 2 >> put (n,l)
-  put (SymKS ts)         = putWord8 3 >> put ts
-  put (SymKP d vs)       = putWord8 4 >> put (d,vs)
-  put SymBIND            = putWord8 5
-  put SymSOFT_BIND       = putWord8 6
-  put SymNE              = putWord8 7
-  put SymSOFT_SPACE      = putWord8 8
-  put SymCAPIT           = putWord8 9
-  put SymALL_CAPIT       = putWord8 10
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM3 SymCat get get get
-             1 -> liftM2 SymLit get get
-             2 -> liftM2 SymVar get get
-             3 -> liftM  SymKS  get
-             4 -> liftM2 (\d vs -> SymKP d vs) get get
-             5 -> return SymBIND
-             6 -> return SymSOFT_BIND
-             7 -> return SymNE
-             8 -> return SymSOFT_SPACE
-             9 -> return SymCAPIT
-             10-> return SymALL_CAPIT
-             _ -> decodingError
-
 --putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
 --getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
 --putGFOVersion = put gfoVersion
@@ -372,7 +332,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/GF/Grammar/CFG.hs

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

src/compiler/GF/Grammar/Canonical.hs

@@ -9,11 +9,9 @@
 
 {-# 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
@@ -60,7 +58,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 
 -- | Linearization value, RHS of @lin@
 data LinValue = ConcatValue LinValue LinValue
-              | LiteralValue Literal
+              | LiteralValue LinLiteral
               | ErrorValue String
               | ParamConstant ParamValue
               | PredefValue PredefId
@@ -76,6 +74,11 @@ data LinValue = ConcatValue LinValue LinValue
               | CommentedValue String LinValue
               deriving (Eq,Ord,Show)
 
+data LinLiteral = FloatConstant Float
+                | IntConstant Int
+                | StrConstant String
+                deriving (Eq,Ord,Show)
+
 data LinPattern = ParamPattern ParamPattern
                 | RecordPattern [RecordRow LinPattern]
                 | TuplePattern [LinPattern]
@@ -117,8 +120,9 @@ newtype FunId = FunId Id  deriving (Eq,Show)
 
 data VarId = Anonymous | VarId Id  deriving Show
 
-newtype Flags = Flags [(FlagName,Literal)] deriving Show
+newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
 type FlagName = Id
+data FlagValue = Str String | Int Int | Flt Double deriving Show
 
 
 -- *** Identifiers
@@ -239,13 +243,13 @@ instance PPA LinValue where
              VarValue v -> pp v
              _ -> parens lv
 
-instance Pretty Literal where pp = ppA
+instance Pretty LinLiteral where pp = ppA
 
-instance PPA Literal where
+instance PPA LinLiteral where
   ppA l = case l of
-            LFlt f -> pp f
-            LInt n -> pp n
-            LStr s -> doubleQuotes s -- hmm
+            FloatConstant f -> pp f
+            IntConstant n -> pp n
+            StrConstant s -> doubleQuotes s -- hmm
 
 instance RhsSeparator LinValue where rhsSep _ = pp "="
 
@@ -294,6 +298,11 @@ instance Pretty Flags where
     where
       ppFlag (name,value) = name <+> "=" <+> value <>";"
 
+instance Pretty FlagValue where
+  pp (Str s) = pp s
+  pp (Int i) = pp i
+  pp (Flt d) = pp d
+
 --------------------------------------------------------------------------------
 -- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
 class Pretty a => PPA a where ppA :: a -> Doc

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -8,7 +8,7 @@ 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)
@@ -171,13 +171,13 @@ instance JSON LinValue where
     <|>        do vs <- readJSON o :: Result [LinValue]
                   return (foldr1 ConcatValue vs)
 
-instance JSON Literal where
+instance JSON LinLiteral 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
+  showJSON (StrConstant   s) = showJSON s
+  showJSON (FloatConstant f) = showJSON f
+  showJSON (IntConstant   n) = showJSON n
 
-  readJSON = readBasicJSON LStr LInt LFlt
+  readJSON = readBasicJSON StrConstant IntConstant FloatConstant
 
 instance JSON LinPattern where
   -- wildcards and patterns without arguments are encoded as strings:
@@ -262,6 +262,15 @@ instance JSON Flags where
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
                                       return (rawIdentS lbl, value)
 
+instance JSON FlagValue where
+  -- flag values are encoded as basic JSON types:
+  showJSON (Str s) = showJSON s
+  showJSON (Int i) = showJSON i
+  showJSON (Flt f) = showJSON f
+
+  readJSON = readBasicJSON Str Int Flt
+
+
 --------------------------------------------------------------------------------
 -- ** Convenience functions
 

src/compiler/GF/Grammar/EBNF.hs

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

src/compiler/GF/Grammar/Grammar.hs

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        PMCFGCat(..), PMCFGRule(..)
+        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence
         ) where
 
 import GF.Infra.Ident
@@ -73,8 +73,7 @@ import GF.Infra.Location
 
 import GF.Data.Operations
 
-import PGF2(BindType(..))
-import PGF2.Transactions(Symbol,LIndex,LParam)
+import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -100,6 +99,7 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
+    mseqs   :: Maybe (Array SeqId Sequence),
     jments  :: Map.Map Ident Info
   }
 
@@ -304,11 +304,14 @@ allConcreteModules gr =
   [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
 
 
-data PMCFGCat  = PMCFGCat LIndex [(LIndex,LParam)]
-                 deriving (Eq,Show)
+data Production = Production {-# UNPACK #-} !FId
+                             {-# UNPACK #-} !FunId
+                             [[FId]]
+                  deriving (Eq,Ord,Show)
 
-data PMCFGRule = PMCFGRule PMCFGCat [PMCFGCat] [[Symbol]]
-                 deriving (Eq,Show)
+data PMCFG = PMCFG [Production]
+                   (Array FunId (UArray LIndex SeqId)) 
+             deriving (Eq,Show)
 
 -- | the constructors are judgements in 
 --
@@ -325,18 +328,15 @@ data Info =
  | AbsFun   (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
 
 -- judgements in resource
- | ResParam (Maybe (L [Param])) (Maybe ([Term],Int)) -- ^ (/RES/) The second argument is list of all possible values
-                                                     -- and its precomputed length.
- | ResValue (L Type) Int                             -- ^ (/RES/) to mark parameter constructors for lookup.
-                                                     -- The second argument is the offset into the list of all values
-                                                     -- where that constructor appears first.
- | ResOper  (Maybe (L Type)) (Maybe (L Term))        -- ^ (/RES/)
+ | ResParam (Maybe (L [Param])) (Maybe [Term])   -- ^ (/RES/) the second parameter is list of all possible values
+ | ResValue (L Type)                             -- ^ (/RES/) to mark parameter constructors for lookup
+ | ResOper  (Maybe (L Type)) (Maybe (L Term))    -- ^ (/RES/)
 
- | ResOverload [ModuleName] [(L Type,L Term)]        -- ^ (/RES/) idents: modules inherited
+ | 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 PMCFG) -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe (Ident,Context,Type)) (Maybe (L Term))                  (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
 
 -- indirection to module Ident
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
@@ -353,7 +353,7 @@ data Term =
  | Cn Ident                      -- ^ constant
  | Con Ident                     -- ^ constructor
  | Sort Ident                    -- ^ basic type
- | EInt Integer                  -- ^ integer literal
+ | EInt Int                      -- ^ integer literal
  | EFloat Double                 -- ^ floating point literal
  | K String                      -- ^ string literal or token: @\"foo\"@
  | Empty                         -- ^ the empty string @[]@
@@ -385,7 +385,7 @@ data Term =
  | C Term Term                   -- ^ concatenation: @s ++ t@
  | Glue Term Term                -- ^ agglutination: @s + t@
 
- | EPatt Int (Maybe Int) Patt    -- ^ pattern (in macro definition): # p
+ | EPatt Patt                    -- ^ pattern (in macro definition): # p
  | EPattType Term                -- ^ pattern type: pattern T
 
  | ELincat Ident Term            -- ^ boxed linearization type of Ident
@@ -397,7 +397,7 @@ data Term =
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
  | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
- | TSymCat Int LIndex [(LIndex,Ident)]
+ | Error String                  -- ^ error values returned by Predef.error
   deriving (Show, Eq, Ord)
 
 -- | Patterns
@@ -408,7 +408,7 @@ data Patt =
  | PW                     -- ^ wild card pattern: @_@
  | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@  -- only concrete
  | PString String         -- ^ string literal pattern: @\"foo\"@  -- only abstract
- | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
+ | PInt    Int            -- ^ integer literal pattern: @12@    -- only abstract
  | PFloat Double          -- ^ float literal pattern: @1.2@    -- only abstract
  | PT Type Patt           -- ^ type-annotated pattern
 
@@ -420,23 +420,18 @@ data Patt =
  -- regular expression patterns
  | PNeg Patt              -- ^ negated pattern: -p
  | PAlt Patt Patt         -- ^ disjunctive pattern: p1 | p2
- | PSeq Int (Maybe Int) Patt Int (Maybe Int) Patt
-                          -- ^ sequence of token parts: p + q
-                          -- In the constructor PSeq minp maxp p minq maxq q,
-                          -- minp/maxp and minq/maxq are the minimal/maximal
-                          -- length of a matching string for p/q.
- | PRep Int (Maybe Int) Patt
-                          -- ^ repetition of token part: p*
-                          -- In the constructor PRep minp maxp p,
-                          -- minp/maxp is the minimal/maximal length of
-                          -- a matching string for p.
- 
+ | PSeq Patt Patt         -- ^ sequence of token parts: p + q
+ | PMSeq MPatt MPatt      -- ^ sequence of token parts: p + q
+ | PRep Patt              -- ^ repetition of token part: p*
  | PChar                  -- ^ string of length one: ?
  | PChars [Char]          -- ^ character list: ["aeiou"]
  | PMacro Ident           -- #p
  | PM QIdent              -- #m.p
   deriving (Show, Eq, Ord)
 
+-- | Measured pattern (paired with the min & max matching length)
+type MPatt = ((Int,Int),Patt)
+
 -- | to guide computation and type checking of tables
 data TInfo = 
    TRaw         -- ^ received from parser; can be anything
@@ -453,7 +448,7 @@ data Label =
 
 type MetaId = Int
 
-type Hypo     = (BindType,Ident,Type)   -- (x:A)  (_:A)  A  ({x}:A)
+type Hypo     = (BindType,Ident,Term)   -- (x:A)  (_:A)  A  ({x}:A)
 type Context  = [Hypo]                  -- (x:A)(y:B)   (x,y:A)   (_,_:A)
 type Equation = ([Patt],Term) 
 

src/compiler/GF/Grammar/Lexer.x

@@ -130,7 +130,7 @@ data Token
  | T_separator
  | T_nonempty
  | T_String  String          -- string literals
- | T_Integer Integer         -- integer literals
+ | T_Integer Int             -- integer literals
  | T_Double  Double          -- double precision float literals
  | T_Ident   Ident
  | T_EOF

src/compiler/GF/Grammar/Lookup.hs

@@ -78,12 +78,12 @@ lookupResDefLoc gr (m,c)
         CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
         CncCat _ _ _ _ _         -> fmap noLoc (lock c defLinType)
 
-        CncFun (Just (_,cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
-        CncFun _                  (Just ltr) _ _ -> return ltr
+        CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
+        CncFun _                (Just ltr) _ _ -> return ltr
 
         AnyInd _ n        -> look n c
         ResParam _ _      -> return (noLoc (QC (m,c)))
-        ResValue _ _      -> return (noLoc (QC (m,c)))
+        ResValue _        -> return (noLoc (QC (m,c)))
         _   -> raise $ render (c <+> "is not defined in resource" <+> m)
 
 lookupResType :: ErrorMonad m => Grammar -> QIdent -> m Type
@@ -94,12 +94,12 @@ lookupResType gr (m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
-    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
+    CncFun (Just (cat,cont,val)) _ _ _ -> do
           val' <- lock cat val
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
-    ResParam _ _    -> return typePType
-    ResValue (L _ t) _ -> return t
+    ResParam _ _      -> return typePType
+    ResValue (L _ t)  -> return t
     _   -> raise $ render (c <+> "has no type defined in resource" <+> m)
 
 lookupOverloadTypes :: ErrorMonad m => Grammar -> QIdent -> m [(Term,Type)]
@@ -110,11 +110,11 @@ lookupOverloadTypes gr id@(m,c) = do
 
     -- used in reused concrete
     CncCat _ _ _ _ _ -> ret typeType
-    CncFun (Just (_,cat,cont,val)) _ _ _ -> do
+    CncFun (Just (cat,cont,val)) _ _ _ -> do
           val' <- lock cat val
           ret $ mkProd cont val' []
-    ResParam _ _    -> ret typePType
-    ResValue (L _ t) _ -> ret t
+    ResParam _ _      -> ret typePType
+    ResValue (L _ t)  -> ret t
     ResOverload os tysts -> do
             tss <- mapM (\x -> lookupOverloadTypes gr (x,c)) os
             return $ [(tr,ty) | (L _ ty,L _ tr) <- tysts] ++
@@ -154,8 +154,8 @@ lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
 lookupParamValues gr c = do
   (_,info) <- lookupOrigInfo gr c
   case info of
-    ResParam _ (Just (pvs,_)) -> return pvs
-    _                         -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
+    ResParam _ (Just pvs) -> return pvs
+    _                     -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
 
 allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term]
 allParamValues cnc ptyp =
@@ -226,9 +226,9 @@ allOpers gr =
     typesIn info = case info of
       AbsFun  (Just ltyp) _ _ _ -> [ltyp]
       ResOper (Just ltyp) _     -> [ltyp]
-      ResValue ltyp _           -> [ltyp]
+      ResValue ltyp             -> [ltyp]
       ResOverload _ tytrs       -> [ltyp | (ltyp,_) <- tytrs]
-      CncFun  (Just (_,i,ctx,typ)) _ _ _ ->
+      CncFun  (Just (i,ctx,typ)) _ _ _ ->
                                    [L NoLoc (mkProdSimple ctx (lock' i typ))]
       _                         -> []
 

src/compiler/GF/Grammar/Macros.hs

@@ -216,7 +216,7 @@ typeTok   = Sort cTok
 typeStrs  = Sort cStrs
 
 typeString, typeFloat, typeInt :: Type
-typeInts :: Integer -> Type
+typeInts :: Int -> Type
 typePBool :: Type
 typeError :: Type
 
@@ -227,7 +227,7 @@ typeInts i = App (cnPredef cInts) (EInt i)
 typePBool = cnPredef cPBool
 typeError = cnPredef cErrorType
 
-isTypeInts :: Type -> Maybe Integer
+isTypeInts :: Type -> Maybe Int
 isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
 isTypeInts _                                      = Nothing
 
@@ -238,6 +238,12 @@ isPredefConstant t = case t of
   Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True
   _                                               -> False
 
+checkPredefError :: Fail.MonadFail m => Term -> m Term
+checkPredefError t =
+    case t of
+      Error s -> fail ("Error: "++s)
+      _ -> return t
+
 cnPredef :: Ident -> Term
 cnPredef f = Q (cPredef,f)
 
@@ -318,7 +324,7 @@ freshAsTerm s = Vr (varX (readIntArg s))
 string2term :: String -> Term
 string2term = K
 
-int2term :: Integer -> Term
+int2term :: Int -> Term
 int2term = EInt
 
 float2term :: Double -> Term
@@ -378,7 +384,7 @@ term2patt trm = case termForm trm of
     return (PNeg a')
   Ok ([], Cn id, [a]) | id == cRep -> do
     a' <- term2patt a
-    return (PRep 0 Nothing a')
+    return (PRep a')
   Ok ([], Cn id, []) | id == cRep -> do
     return PChar
   Ok ([], Cn id,[K s]) | id == cChars  -> do
@@ -386,7 +392,7 @@ term2patt trm = case termForm trm of
   Ok ([], Cn id, [a,b]) | id == cSeq -> do
     a' <- term2patt a
     b' <- term2patt b
-    return (PSeq 0 Nothing a' 0 Nothing b')
+    return (PSeq a' b')
   Ok ([], Cn id, [a,b]) | id == cAlt -> do
     a' <- term2patt a
     b' <- term2patt b
@@ -416,9 +422,9 @@ patt2term pt = case pt of
   PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
   PChar     -> appCons cChar  []                             --- an encoding
   PChars s  -> appCons cChars [K s]                          --- an encoding
-  PSeq _ _ a _ _ b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
+  PSeq a b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
   PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
-  PRep _ _ a-> appCons cRep   [(patt2term a)]                --- an encoding
+  PRep a    -> appCons cRep   [(patt2term a)]                --- an encoding
   PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
 
 
@@ -469,8 +475,9 @@ composPattOp op patt =
     PImplArg p      -> liftM  PImplArg (op p)
     PNeg p          -> liftM  PNeg (op p)
     PAlt p1 p2      -> liftM2 PAlt (op p1) (op p2)
-    PSeq _ _ p1 _ _ p2  -> liftM2 (\p1 p2 -> PSeq 0 Nothing p1 0 Nothing p2) (op p1) (op p2)
-    PRep _ _ p      -> liftM  (PRep 0 Nothing) (op p)
+    PSeq p1 p2      -> liftM2 PSeq (op p1) (op p2)
+    PMSeq (_,p1) (_,p2) -> liftM2 PSeq (op p1) (op p2) -- information loss
+    PRep p          -> liftM  PRep (op p)
     _               -> return patt -- covers cases without subpatterns
 
 collectOp :: Monoid m => (Term -> m) -> Term -> m
@@ -507,8 +514,9 @@ collectPattOp op patt =
     PImplArg p      -> op p
     PNeg p          -> op p
     PAlt p1 p2      -> op p1++op p2
-    PSeq _ _ p1 _ _ p2 -> op p1++op p2
-    PRep _ _ p      -> op p
+    PSeq p1 p2      -> op p1++op p2
+    PMSeq (_,p1) (_,p2) -> op p1++op p2
+    PRep p          -> op p
     _               -> []     -- covers cases without subpatterns
 
 

src/compiler/GF/Grammar/Parser.y

@@ -25,6 +25,7 @@ import GF.Compile.Update (buildAnyTree)
 import Data.List(intersperse)
 import Data.Char(isAlphaNum)
 import qualified Data.Map as Map
+import PGF(mkCId)
 
 }
 
@@ -132,14 +133,14 @@ ModDef
                                           (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
                                       jments <- mapM (checkInfoType mtype) jments
                                       defs <- buildAnyTree id jments
-                                      return (id, ModInfo mtype mstat opts extends with opens [] "" defs)  }
+                                      return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs)  }
 
 ModHeader :: { SourceModule }
 ModHeader
   : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
                                                (mtype,id) = $2 ;
                                                (extends,with,opens) = $4 }
-                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) }
+                                         in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
 
 ComplMod :: { ModuleStatus }
 ComplMod 
@@ -267,7 +268,7 @@ DataDef
 ParamDef :: { [(Ident,Info)] }
 ParamDef
   : Posn LhsIdent '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
-                                           [(f, ResValue (L loc (mkProdSimple co (Cn $2))) 0) | L loc (f,co) <- $4] }
+                                        [(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
   | Posn LhsIdent                   Posn { [($2, ResParam Nothing Nothing)] }
 
 OperDef :: { [(Ident,Info)] }
@@ -444,7 +445,7 @@ Exp4
   | 'pre' '{' String ';' ListAltern '}' { Alts (K $3) $5 }
   | 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3) $5 }
   | 'strs' '{' ListExp '}'           { Strs $3       }
-  | '#' Patt3                        { EPatt 0 Nothing $2 }
+  | '#' Patt3                        { EPatt $2      }
   | 'pattern' Exp5                   { EPattType $2  }
   | 'lincat' Ident Exp5              { ELincat $2 $3 }
   | 'lin' Ident Exp5                 { ELin $2 $3 }
@@ -485,14 +486,14 @@ Exps
 Patt :: { Patt }
 Patt
   : Patt '|' Patt1            { PAlt $1 $3 } 
-  | Patt '+' Patt1            { PSeq 0 Nothing $1 0 Nothing $3 }
+  | Patt '+' Patt1            { PSeq $1 $3 }
   | Patt1                     { $1         }
 
 Patt1 :: { Patt }
 Patt1
   : Ident ListPatt            { PC $1 $2 } 
   | ModuleName '.' Ident ListPatt  { PP ($1,$3) $4 }
-  | Patt3 '*'                 { PRep 0 Nothing $1 }
+  | Patt3 '*'                 { PRep $1 }
   | Patt2                     { $1 }
 
 Patt2 :: { Patt }
@@ -624,7 +625,7 @@ ListCFRule
 
 CFRule :: { [BNFCRule] }
 CFRule
-  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
+  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
                                            }
   | Ident '::=' ListCFRHS ';'              { let { cat = showIdent $1;
                                                    mkFun cat its =
@@ -637,7 +638,7 @@ CFRule
                                                        Terminal    c     -> filter isAlphaNum c;
                                                        NonTerminal (t,_) -> t
                                                      }
-                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
+                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
                                            }
   | 'coercions' Ident Integer ';'          { [BNFCCoercions (showIdent $2) $3]}
   | 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }
@@ -774,7 +775,7 @@ checkInfoType mt jment@(id,info) =
     CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
     CncFun _   pd ppn _  -> ifConcrete mt (locPerh pd ++ locPerh ppn)
     ResParam pparam _    -> ifResource mt (locPerh pparam)
-    ResValue ty _        -> ifResource mt (locL ty)
+    ResValue ty          -> ifResource mt (locL ty)
     ResOper  pty pt      -> ifOper mt pty pt
     ResOverload _ xs     -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
   where

src/compiler/GF/Grammar/PatternMatch.hs

@@ -15,7 +15,8 @@
 module GF.Grammar.PatternMatch (
                                 matchPattern,
                                 testOvershadow,
-                                findMatch
+                                findMatch,
+                                measurePatt
                                ) where
 
 import GF.Data.Operations
@@ -24,7 +25,7 @@ import GF.Infra.Ident
 import GF.Grammar.Macros
 --import GF.Grammar.Printer
 
-import Data.Maybe(fromMaybe)
+--import Data.List
 import Control.Monad
 import GF.Text.Pretty
 --import Debug.Trace
@@ -121,10 +122,11 @@ tryMatch (p,t) = do
         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
+      (PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
+      (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
 
-      (PRep _ _ p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "")
+      (PRep p1, ([],K s, [])) -> checks [
+         trym (foldr (const (PSeq p1)) (PString "")
            [1..n]) t' | n <- [0 .. length s]
         ] >>
         return []
@@ -138,14 +140,50 @@ tryMatch (p,t) = do
   words2term [w]    = K w
   words2term (w:ws) = C (K w) (words2term ws)
 
-matchPSeq min1 max1 p1 min2 max2 p2 s =
+
+matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
+--matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
+matchPSeq p1 p2 s = matchPSeq' (lengthBounds p1) p1 (lengthBounds p2) p2 s
+
+matchPSeq' b1@(min1,max1) p1 b2@(min2,max2) p2 s =
   do let n = length s
-         lo = min1 `max` (n-fromMaybe n max2)
-         hi = (n-min2) `min` (fromMaybe n max1)
+         lo = min1 `max` (n-max2)
+         hi = (n-min2) `min` max1
          cuts = [splitAt i s | i <- [lo..hi]]
      matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
      return (concat matches)
 
+-- | Estimate the minimal length of the string that a pattern will match
+minLength = matchLength 0 id (+) min -- safe underestimate
+
+-- | Estimate the maximal length of the string that a pattern will match
+maxLength =
+    maybe maxBound id . matchLength Nothing Just (liftM2 (+)) (liftM2 max)
+        -- safe overestimate
+
+matchLength unknown known seq alt = len
+  where
+    len p =
+      case p of
+        PString s  -> known (length s)
+        PSeq p1 p2 -> seq (len p1) (len p2)
+        PAlt p1 p2 -> alt (len p1) (len p2)
+        PChar      -> known 1
+        PChars _   -> known 1
+        PAs x p'   -> len p'
+        PT t p'    -> len p'
+        _          -> unknown
+
+lengthBounds p = (minLength p,maxLength p)
+
+mPatt p = (lengthBounds p,measurePatt p)
+
+measurePatt p =
+  case p of
+    PSeq p1 p2 -> PMSeq (mPatt p1) (mPatt p2)
+    _ -> composSafePattOp measurePatt p
+
+
 isInConstantForm :: Term -> Bool
 isInConstantForm trm = case trm of
     Cn _     -> True

src/compiler/GF/Grammar/Predef.hs

@@ -61,6 +61,7 @@ cRead = identS "read"
 cToStr = identS "toStr"
 cMapStr = identS "mapStr"
 cError = identS "error"
+cTrace = identS "trace"
 
 -- * Hacks: dummy identifiers used in various places.
 -- Not very nice!

src/compiler/GF/Grammar/Printer.hs

@@ -24,19 +24,20 @@ module GF.Grammar.Printer
            ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
-import PGF2(Literal(..))
-import PGF2.Transactions(LIndex,LParam,Symbol(..))
 import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.Values
 import GF.Grammar.Grammar
 
+import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
+
 import GF.Text.Pretty
 import Data.Maybe (isNothing)
 import Data.List  (intersperse)
 import qualified Data.Map as Map
+--import qualified Data.IntMap as IntMap
+--import qualified Data.Set as Set
 import qualified Data.Array.IArray as Array
-import qualified GHC.Show
 
 data TermPrintQual
   = Terse | Unqualified | Qualified | Internal
@@ -46,10 +47,11 @@ instance Pretty Grammar where
   pp = vcat . map (ppModule Qualified) . modules
 
 ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
     hdr $$
     nest 2 (ppOptions opts $$
-            vcat (map (ppJudgement q) (Map.toList jments))) $$
+            vcat (map (ppJudgement q) (Map.toList jments)) $$
+            maybe empty (ppSequences q) mseqs) $$
     ftr
     where
       hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -108,10 +110,10 @@ ppJudgement q (id, ResParam pparams _) =
   (case pparams of
      Just (L _ ps) -> '=' <+> ppParams q ps
      _             -> empty) <+> ';'
-ppJudgement q (id, ResValue pvalue idx) =
+ppJudgement q (id, ResValue pvalue) =
   "-- param constructor" <+> id <+> ':' <+>
   (case pvalue of
-     (L _ ty) -> ppTerm q 0 ty) <+> ';' <+> parens (pp "index = " <> pp idx)
+     (L _ ty) -> ppTerm q 0 ty) <+> ';'
 ppJudgement q (id, ResOper  ptype pexp) =
   "oper" <+> id <+>
   (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
@@ -121,8 +123,8 @@ ppJudgement q (id, ResOverload ids defs) =
   ("overload" <+> '{' $$
    nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
    '}') <+> ';'
-ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
-  (case mtyp of
+ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
+  (case pcat of
      Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
      Nothing        -> empty) $$
   (case pdef of
@@ -134,13 +136,17 @@ ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) =
   (case pprn of
      Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
-  (case (mtyp,mpmcfg,q) of
-     (Just (L _ typ),Just rules,Internal)
-                    -> "pmcfg" <+> '{' $$
-                       nest 2 (vcat (map (ppPmcfgRule id [] id) rules)) $$
+  (case (mpmcfg,q) of
+     (Just (PMCFG prods funs),Internal)
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
+                       nest 2 (vcat (map ppProduction prods) $$
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+                                         (Array.assocs funs))) $$
                        '}'
      _              -> empty)
-ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
+ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
   (case pdef of
      Just (L _ e) -> let (xs,e') = getAbs e
                      in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
@@ -148,10 +154,14 @@ ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) =
   (case pprn of
      Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
      Nothing        -> empty) $$
-  (case (mtyp,mpmcfg,q) of
-     (Just (args,res,_,_),Just rules,Internal)
-                    -> "pmcfg" <+> '{' $$
-                       nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
+  (case (mpmcfg,q) of
+     (Just (PMCFG prods funs),Internal)
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
+                       nest 2 (vcat (map ppProduction prods) $$
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+                                         (Array.assocs funs))) $$
                        '}'
      _              -> empty)
 ppJudgement q (id, AnyInd cann mid) =
@@ -159,13 +169,6 @@ ppJudgement q (id, AnyInd cann mid) =
     Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
     _        -> empty
 
-ppPmcfgRule id arg_cats res_cat (PMCFGRule res args lins) =
-  pp id <+> (':' <+> hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->" <+> ppPmcfgCat res_cat res $$
-             '=' <+> brackets (vcat (map (hsep . map ppSymbol) lins)))
-
-ppPmcfgCat :: Ident -> PMCFGCat -> Doc
-ppPmcfgCat cat (PMCFGCat r rs) = pp cat <> parens (ppLinFun ppLParam r rs)
-
 instance Pretty Term where pp = ppTerm Unqualified 0
 
 ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
@@ -210,7 +213,7 @@ ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (m
 ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
 ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
 ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
-ppTerm q d (EPatt _ _ p)=prec d 4 ('#' <+> ppPatt q 2 p)
+ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)
 ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
 ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
 ppTerm q d (Cn id)     = pp id
@@ -238,7 +241,7 @@ ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
 ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
 ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
-ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun pp r rs <> pp '>'
+ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
 
 ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 
@@ -247,14 +250,15 @@ ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
 instance Pretty Patt where pp = ppPatt Unqualified 0
 
 ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
-ppPatt q d (PSeq _ _ p1 _ _ p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
 ppPatt q d (PC f ps)    = if null ps
                             then pp f
                             else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
 ppPatt q d (PP f ps)    = if null ps
                             then ppQIdent q f
                             else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
-ppPatt q d (PRep _ _ p) = prec d 1 (ppPatt q 3 p <> '*')
+ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')
 ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
 ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
 ppPatt q d (PChar)      = pp '?'
@@ -286,12 +290,7 @@ ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue
 ppEnv :: Env -> Doc
 ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
 
-str s = doubleQuotes (pp (foldr showLitChar "" s))
-  where
-    showLitChar c
-      | c == '"'    = showString "\\\""
-      | c > '\DEL'  = showChar c
-      | otherwise   = GHC.Show.showLitChar c
+str s = doubleQuotes s
 
 ppDecl q (_,id,typ)
   | id == identW = ppTerm q 3 typ
@@ -329,6 +328,18 @@ ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
 ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
 ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
 
+ppProduction (Production fid funid args) =
+  ppFId fid <+> "->" <+> ppFunId funid <>
+  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
+
+ppSequences q seqsArr
+  | null seqs || q /= Internal = empty
+  | otherwise                  = "sequences" <+> '{' $$
+                                 nest 2 (vcat (map ppSeq seqs)) $$
+                                 '}'
+  where
+    seqs = Array.assocs seqsArr
+
 commaPunct f ds = (hcat (punctuate "," (map f ds)))
 
 prec d1 d2 doc
@@ -351,41 +362,3 @@ getLet :: Term -> ([LocalDef], Term)
 getLet (Let l e) = let (ls,e') = getLet e
                    in (l:ls,e')
 getLet e         = ([],e)
-
-ppMeta :: Int -> Doc
-ppMeta n
-  | n == 0    = pp '?'
-  | otherwise = pp '?' <> pp n
-
-ppLit (LStr s) = pp (show s)
-ppLit (LInt n) = pp n
-ppLit (LFlt d) = pp d
-
-ppSymbol (SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppLParam r rs <> pp '>'
-ppSymbol (SymLit d r)   = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
-ppSymbol (SymVar d r)   = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
-ppSymbol (SymKS t)      = doubleQuotes (pp t)
-ppSymbol SymNE          = pp "nonExist"
-ppSymbol SymBIND        = pp "BIND"
-ppSymbol SymSOFT_BIND   = pp "SOFT_BIND"
-ppSymbol SymSOFT_SPACE  = pp "SOFT_SPACE"
-ppSymbol SymCAPIT       = pp "CAPIT"
-ppSymbol SymALL_CAPIT   = pp "ALL_CAPIT"
-ppSymbol (SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
-
-ppLinFun ppParam r rs
-  | r == 0 && not (null rs) = hcat (intersperse (pp '+') (       map ppTerm rs))
-  | otherwise               = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
-  where
-    ppTerm (i,p)
-      | i == 1    = ppParam p
-      | otherwise = pp i <> pp '*' <> ppParam p
-
-ppLParam p
-  | i == 0    = pp (chars !! j)
-  | otherwise = pp (chars !! j : show i)
-  where
-    chars = "ijklmnopqr"
-    (i,j) = p `divMod` (length chars)
-
-ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

src/compiler/GF/Infra/BuildInfo.hs

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

src/compiler/GF/Infra/CheckM.hs

@@ -13,13 +13,13 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.CheckM
-          (Check, CheckResult(..), Message, runCheck, runCheck',
+          (Check, CheckResult, Message, runCheck, runCheck',
            checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
            checkIn, checkInModule, checkMap, checkMapRecover,
-           accumulateError, commitCheck,
+           parallelCheck, accumulateError, commitCheck,
           ) where
-
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
 import GF.Data.Operations
 --import GF.Infra.Ident
 --import GF.Grammar.Grammar(msrc) -- ,Context
@@ -118,15 +118,39 @@ runCheck' opts c =
     list = vcat . reverse
     wlist ws = if verbAtLeast opts Normal then list ws else empty
 
+parallelCheck :: [Check a] -> Check [a]
+parallelCheck cs =
+  Check $ \ {-ctxt-} (es0,ws0) ->
+  let os = [unCheck c {-[]-} ([],[])|c<-cs] `using` parList rseq
+      (msgs1,crs) = unzip os
+      (ess,wss) = unzip msgs1
+      rs = [r | Success r<-crs]
+      fs = [f | Fail f<-crs]
+      msgs = (concat ess++es0,concat wss++ws0)
+  in if null fs
+     then (msgs,Success rs)
+     else (msgs,Fail (vcat $ reverse fs))
+
 checkMap :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
 checkMap f map = do xs <- mapM (\(k,v) -> do v <- f k v
                                              return (k,v)) (Map.toList map)
                     return (Map.fromAscList xs)
 
 checkMapRecover :: (Ord a) => (a -> b -> Check b) -> Map.Map a b -> Check (Map.Map a b)
-checkMapRecover f = fmap Map.fromList . mapM f' . Map.toList
+checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
   where f' (k,v) = fmap ((,)k) (f k v)
 
+{-
+checkMapRecover f mp = do
+  let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
+  case [s | (_,Bad s) <- xs] of
+    ss@(_:_) -> checkError (text (unlines ss))
+    _   -> do
+      let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
+      if not (all null ss) then checkWarn (text (unlines ss)) else return ()
+      return (Map.fromAscList kx)
+-}
+
 checkIn :: Doc -> Check a -> Check a
 checkIn msg c = Check $ \{-ctxt-} msgs0 ->
     case unCheck c {-ctxt-} ([],[]) of

src/compiler/GF/Infra/Ident.hs

@@ -31,7 +31,7 @@ import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
                  -- Limit use of BS functions to the ones that work correctly on
                  -- UTF-8-encoded bytestrings!
 import Data.Char(isDigit)
-import Data.Binary(Binary(..))
+import PGF.Internal(Binary(..))
 import GF.Text.Pretty
 
 

src/compiler/GF/Infra/Location.hs

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

src/compiler/GF/Infra/Option.hs

@@ -34,14 +34,16 @@ import Data.Maybe
 import GF.Infra.Ident
 import GF.Infra.GetOpt
 import GF.Grammar.Predef
+--import System.Console.GetOpt
 import System.FilePath
-import PGF2(Literal(..))
+--import System.IO
 
 import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
 
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import PGF.Internal(Literal(..))
 import qualified Control.Monad.Fail as Fail
 
 usageHeader :: String
@@ -74,6 +76,7 @@ errors = raise . unlines
 
 data Mode = ModeVersion | ModeHelp
           | ModeInteractive | ModeRun
+          | ModeInteractive2 | ModeRun2
           | ModeCompiler
           | ModeServer {-port::-}Int
   deriving (Show,Eq,Ord)
@@ -92,6 +95,7 @@ data OutputFormat = FmtPGFPretty
                   | FmtPython
                   | FmtHaskell
                   | FmtJava
+                  | FmtProlog
                   | FmtBNF
                   | FmtEBNF
                   | FmtRegular
@@ -152,14 +156,13 @@ data Flags = Flags {
       optVerbosity       :: Verbosity,
       optShowCPUTime     :: Bool,
       optOutputFormats   :: [OutputFormat],
-      optLinkTargets     :: (Bool,Bool), -- pgf,ngf files
       optSISR            :: Maybe SISRFormat,
       optHaskellOptions  :: Set HaskellOption,
       optLexicalCats     :: Set String,
       optLiteralCats     :: Set Ident,
       optGFODir          :: Maybe FilePath,
       optOutputDir       :: Maybe FilePath,
-      optGFLibPath       :: Maybe FilePath,
+      optGFLibPath       :: Maybe [FilePath],
       optDocumentRoot    :: Maybe FilePath, -- For --server mode
       optRecomp          :: Recomp,
       optProbsFile       :: Maybe FilePath,
@@ -214,9 +217,10 @@ parseModuleOptions args = do
     then return opts
     else errors $ map ("Non-option among module options: " ++) nonopts
 
-fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
+fixRelativeLibPaths curr_dir lib_dirs (Options o) = Options (fixPathFlags . o)
   where
-    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
+    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [parent </> dir
+                                                                                      | parent <- curr_dir : lib_dirs]) path}
 
 -- Showing options
 
@@ -263,7 +267,6 @@ defaultFlags = Flags {
       optVerbosity       = Normal,
       optShowCPUTime     = False,
       optOutputFormats   = [],
-      optLinkTargets     = (True,False),
       optSISR            = Nothing,
       optHaskellOptions  = Set.empty,
       optLiteralCats     = Set.fromList [cString,cInt,cFloat,cVar],
@@ -313,6 +316,8 @@ optDescr =
      Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
      Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
      Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
+     Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.",
+     Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).",
      Option [] ["server"] (OptArg modeServer "port") $
        "Run in HTTP server mode on given port (default "++show defaultPort++").",
      Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
@@ -322,8 +327,6 @@ optDescr =
      Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
      Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
      Option [] ["make"] (NoArg (liftM2 addOptions (mode ModeCompiler) (phase Link))) "Build .pgf file and other output files and exit.",
-     Option [] ["boot"] (NoArg (set $ \o -> o {optLinkTargets = (True,True)})) "Boot an .ngf database for fast grammar reloading",
-     Option [] ["boot-only"] (NoArg (set $ \o -> o {optLinkTargets = (False,True)})) "Boot the .ngf database and don't write a .pgf file",
      Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
      Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
 --   Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
@@ -429,7 +432,7 @@ optDescr =
        literalCat  x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
        lexicalCat  x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
        outDir      x = set $ \o -> o { optOutputDir = Just x }
-       gfLibPath   x = set $ \o -> o { optGFLibPath = Just x }
+       gfLibPath   x = set $ \o -> o { optGFLibPath = Just $ splitInModuleSearchPath x }
        gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
@@ -477,9 +480,12 @@ outputFormatsExpl =
     [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
      (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
+     (("js",           FmtJavaScript),"JavaScript (whole grammar)"),
      (("json",         FmtJSON),"JSON (whole grammar)"),
+     (("python",       FmtPython),"Python (whole grammar)"),
      (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
      (("java",         FmtJava),"Java (abstract syntax)"),
+     (("prolog",       FmtProlog),"Prolog (whole grammar)"),
      (("bnf",          FmtBNF),"BNF (context-free grammar)"),
      (("ebnf",         FmtEBNF),"Extended BNF"),
      (("regular",      FmtRegular),"* regular grammar"),

src/compiler/GF/Infra/SIO.hs

@@ -12,6 +12,9 @@ module GF.Infra.SIO(
        newStdGen,print,putStr,putStrLn,
        -- ** Specific to GF
        importGrammar,importSource,
+#ifdef C_RUNTIME
+       readPGF2,
+#endif
        putStrLnFlush,runInterruptibly,lazySIO,
        -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
        -- | If the environment variable GF_RESTRICTED is defined, these
@@ -24,22 +27,22 @@ import Control.Applicative(Applicative(..))
 import Control.Monad(liftM,ap)
 import Control.Monad.Trans(MonadTrans(..))
 import System.IO(hPutStr,hFlush,stdout)
-import System.IO.Error(isUserError,ioeGetErrorString)
 import GF.System.Catch(try)
 import System.Process(system)
 import System.Environment(getEnv)
 import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
 import GF.Infra.Concurrency(lazyIO)
 import GF.Infra.UseIO(Output(..))
-import GF.Data.Operations(ErrorMonad(..))
 import qualified System.CPUTime as IO(getCPUTime)
 import qualified System.Directory as IO(getCurrentDirectory)
 import qualified System.Random as IO(newStdGen)
 import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
 import qualified GF.System.Signal as IO(runInterruptibly)
 import qualified GF.Command.Importing as GF(importGrammar, importSource)
+#ifdef C_RUNTIME
+import qualified PGF2
+#endif
 import qualified Control.Monad.Fail as Fail
-import Control.Exception
 
 -- * The SIO monad
 
@@ -65,14 +68,6 @@ instance Output SIO where
   putStrLnE = putStrLnFlush
   putStrE = putStr
 
-instance ErrorMonad SIO where
-  raise = fail
-  handle m h = SIO $ \putStr ->
-                 catch (unS m putStr) $
-                    \e -> if isUserError e
-                            then unS (h (ioeGetErrorString e)) putStr
-                            else ioError e
-
 class {- Monad m => -} MonadSIO m where liftSIO :: SIO a -> m a
 -- ^ If the Monad m superclass is included, then the generic instance
 -- for monad transformers below would require UndecidableInstances
@@ -107,7 +102,7 @@ restricted io    = SIO (const (restrictedIO io))
 restrictedSystem = restricted . system
 
 restrictedIO io =
-    either (const io) (const $ fail message) =<< GF.System.Catch.try (getEnv "GF_RESTRICTED")
+    either (const io) (const $ fail message) =<< try (getEnv "GF_RESTRICTED")
   where
     message =
       "This operation is not allowed when GF is running in restricted mode."
@@ -132,3 +127,7 @@ lazySIO              = lift1   lazyIO
 
 importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
 importSource      opts files = lift0 $ GF.importSource      opts files
+
+#ifdef C_RUNTIME
+readPGF2 = lift0 . PGF2.readPGF
+#endif

src/compiler/GF/Infra/UseIO.hs

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

src/compiler/GF/Interactive.hs

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

src/compiler/GF/Interactive2.hs

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

src/compiler/GF/Main.hs

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

src/compiler/GF/Quiz.hs

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

src/compiler/GF/Server.hs

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

src/compiler/GF/Speech/CFGToFA.hs

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

src/compiler/GF/Speech/GSL.hs

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

src/compiler/GF/Speech/JSGF.hs

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

src/compiler/GF/Speech/PGFToCFG.hs

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

src/compiler/GF/Speech/PrRegExp.hs

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

src/compiler/GF/Speech/SISR.hs

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

src/compiler/GF/Speech/SLF.hs

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

src/compiler/GF/Speech/SRG.hs

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

src/compiler/GF/Speech/SRGS_ABNF.hs

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

src/compiler/GF/Speech/SRGS_XML.hs

@@ -13,7 +13,7 @@ import GF.Grammar.CFG
 import GF.Speech.RegExp
 import GF.Speech.SISR as SISR
 import GF.Speech.SRG
-import PGF2 (PGF, Concr)
+import PGF (PGF, CId, Token)
 
 --import Control.Monad
 --import Data.Char (toUpper,toLower)
@@ -22,11 +22,11 @@ import Data.Maybe
 --import qualified Data.Map as Map
 
 srgsXmlPrinter :: Options
-               -> PGF -> Concr -> String
+               -> PGF -> CId -> String
 srgsXmlPrinter opts pgf cnc = prSrgsXml sisr $ makeNonLeftRecursiveSRG opts pgf cnc
     where sisr = flag optSISR opts
 
-srgsXmlNonRecursivePrinter :: Options -> PGF -> Concr -> String
+srgsXmlNonRecursivePrinter :: Options -> PGF -> CId -> String
 srgsXmlNonRecursivePrinter opts pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG opts pgf cnc
 
 

src/compiler/GF/Speech/VoiceXML.hs

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

src/compiler/GF/System/NoSignal.hs

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

src/compiler/GF/Text/Coding.hs

@@ -38,7 +38,7 @@ decodeUnicode :: TextEncoding -> ByteString -> String
 decodeUnicode enc bs = unsafePerformIO $ decodeUnicodeIO enc bs
 
 decodeUnicodeIO enc (PS fptr l len) = do
-    let bbuf = Buffer{bufRaw=fptr, bufState=ReadBuffer, bufSize=len, bufL=l, bufR=l+len}
+    let bbuf = (emptyBuffer fptr len ReadBuffer) { bufL=l, bufR=l+len }
     cbuf <- newCharBuffer 128 WriteBuffer
     case enc of
       TextEncoding {mkTextDecoder=mk} -> do decoder <- mk

src/compiler/GF/Text/Lexing.hs

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

src/compiler/GF/Text/Transliterations.hs

@@ -39,6 +39,7 @@ allTransliterations = Map.fromList [
   ("amharic",transAmharic),
   ("ancientgreek", transAncientGreek),
   ("arabic", transArabic),
+  ("arabic_unvocalized", transArabicUnvoc),
   ("devanagari", transDevanagari),
   ("greek", transGreek),
   ("hebrew", transHebrew),
@@ -178,6 +179,13 @@ transArabic = mkTransliteration "Arabic" allTrans allCodes where
   allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
              [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f]
 
+
+transArabicUnvoc :: Transliteration
+transArabicUnvoc = transArabic{
+  invisible_chars = ["a","u","i","v2","o","V+","V-","a:"],
+  printname = "unvocalized Arabic"
+  }
+
 transPersian :: Transliteration
 transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes)
     {invisible_chars = ["a","u","i"]} where

src/compiler/SimpleEditor/Convert.hs

@@ -17,7 +17,7 @@ import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
 import GF.Grammar.Parser(runP,pModDef)
 import GF.Grammar.Lexer(Posn(..))
 import GF.Data.ErrM
-import PGF2.Internal(Literal(LStr))
+import PGF.Internal(Literal(LStr))
 
 import SimpleEditor.Syntax as S
 import SimpleEditor.JSON

src/example-based/ExampleDemo.hs

@@ -0,0 +1,553 @@
+module ExampleDemo (Environ,initial,getNext, provideExample, testThis,mkFuncWithArg,searchGoodTree,isMeta)
+  where
+
+import PGF
+--import System.IO
+import Data.List
+--import Control.Monad
+import qualified Data.Map as Map
+--import qualified Data.IntMap as IntMap
+import qualified Data.Set as Set
+import Data.Maybe
+--import System.Environment (getArgs)
+import System.Random (RandomGen) --newStdGen
+
+
+type MyType = CId                                -- name of the categories from the program
+type ConcType = CId                              -- categories from the resource grammar, that we parse on
+type MyFunc = CId                                -- functions that we need to implement
+--type FuncWithArg = ((MyFunc, MyType), Expr)    -- function with arguments  
+type InterInstr = [String]                       -- lincats that were generated but not written to the file
+
+
+
+data FuncWithArg = FuncWithArg 
+                      {getName :: MyFunc,        -- name of the function to generate
+                       getType :: MyType,        -- return type of the function
+                       getTypeArgs :: [MyType]  -- types of arguments 
+                       }
+       deriving (Show,Eq,Ord)
+
+-- we assume that it's for English for the moment
+
+
+type TypeMap = Map.Map MyType ConcType           -- mapping found from a file
+
+type ConcMap = Map.Map MyFunc Expr               -- concrete expression after parsing
+
+data Environ = Env {getTypeMap :: TypeMap,                  -- mapping between a category in the grammar and a concrete type from RGL
+                    getConcMap :: ConcMap,                  -- concrete expression after parsing          
+                    getSigs :: Map.Map MyType [FuncWithArg], -- functions for which we have the concrete syntax already with args 
+                    getAll :: [FuncWithArg]           -- all the functions with arguments  
+                    }
+
+
+getNext :: Environ -> Environ -> ([MyFunc],[MyFunc])
+getNext env example_env = 
+  let sgs = getSigs env
+      allfuncs  = getAll env
+      names = Set.fromList $ map getName $ concat $ Map.elems sgs
+      exampleable = filter (\x -> (isJust $ getNameExpr x env) 
+                               &&
+                               (not $ Set.member x names) -- maybe drop this if you want to also rewrite from examples...
+                            ) $ map getName allfuncs
+      testeable = filter (\x -> (isJust $ getNameExpr x env ) 
+                              && 
+                               (Set.member x names)
+                          ) $ map getName allfuncs    
+
+     in (exampleable,testeable)
+
+
+provideExample :: RandomGen gen => gen -> Environ -> MyFunc -> PGF -> PGF -> Language -> Maybe (Expr,String)
+provideExample gen env myfunc parsePGF pgfFile lang = 
+      fmap giveExample $ getNameExpr myfunc env
+ where 
+   giveExample e_ = 
+     let newexpr = head $ generateRandomFromDepth gen pgfFile e_ (Just 5) -- change here with the new random generator
+         ty = getType $ head $ filter (\x -> getName x == myfunc) $ getAll env
+         embeddedExpr = maybe "" (\x -> ", as in: " ++ q (linearize pgfFile lang x)) (embedInStart (getAll env) (Map.fromList [(ty,e_)]))
+         lexpr = linearize pgfFile lang newexpr  
+         q s = sq++s++sq
+         sq = "\""
+       in (newexpr,q lexpr ++ embeddedExpr)
+-- question, you need the IO monad for the random generator, how to do otherwise ??
+-- question can you make the expression bold/italic - somehow distinguishable from the rest ?
+
+
+
+testThis :: Environ -> MyFunc -> PGF -> Language -> Maybe String  
+testThis env myfunc parsePGF lang = 
+    fmap (linearize parsePGF lang . mapToResource env . llin env) $
+    getNameExpr myfunc env  
+
+
+-- we assume that even the functions linearized by the user will still be in getSigs along with their linearization 
+
+
+-- fill in the blancs of an expression that we want to linearize for testing purposes
+---------------------------------------------------------------------------
+
+llin :: Environ -> Expr -> Expr 
+llin env expr = 
+     let 
+         (id,args) = fromJust $ unApp expr
+       --cexpr = fromJust $ Map.lookup id (getConcMap env)
+     in 
+         if any isMeta args 
+              then let 
+                       sigs = concat $ Map.elems $ getSigs env
+                       tys = findExprWhich sigs id
+                    in  replaceConcArg 1 tys expr env 
+           else mkApp id $ map (llin env) args
+
+
+-- argument of the meta variable to replace, list of arguments left, expression to replace, environment, current replace expression 
+replaceConcArg :: Int -> [MyType] -> Expr -> Environ -> Expr
+replaceConcArg i [] expr env = expr
+replaceConcArg i (t:ts) expr env =      -- TO DO : insert randomness here !!
+   let ss = fromJust $ Map.lookup t $ getSigs env 
+       args = filter (null . getTypeArgs) ss 
+       finArg = if null args then let l = last ss in llin env (mkApp (getName l) [mkMeta j | j <- [1..(length $ getTypeArgs l)]]) 
+                   else mkApp (getName $ last args) [] 
+    in   
+                     let newe = replaceOne i finArg expr
+                               in replaceConcArg (i+1) ts newe env       
+                   
+-- replace a certain metavariable with a certain expression in another expression - return updated expression
+replaceOne :: Int -> Expr -> Expr -> Expr                               
+replaceOne i erep expr = 
+      if isMeta expr && ((fromJust $ unMeta expr) == i) 
+               then erep
+        else if isMeta expr then expr
+              else let (id,args) = fromJust $ unApp expr
+                       in  
+                        mkApp id $ map (replaceOne i erep) args
+
+
+findExprWhich :: [FuncWithArg] -> MyFunc -> [MyType]
+findExprWhich lst f = getTypeArgs $ head $ filter (\x -> getName x == f) lst 
+
+
+mapToResource :: Environ -> Expr -> Expr 
+mapToResource env expr = 
+      let (id,args) =  maybe (error $ "tried to unwrap " ++ showExpr [] expr) (\x -> x) (unApp expr)
+          cmap      = getConcMap env
+          cexp      = maybe (error $ "didn't find " ++ showCId id ++ " in  "++ show cmap) (\x -> x)  (Map.lookup id cmap)
+        in 
+        if null args then cexp
+             else let newargs = map (mapToResource env) args
+                   in replaceAllArgs cexp 1 newargs
+      where 
+      replaceAllArgs expr i []     = expr 
+      replaceAllArgs expr i (x:xs) = replaceAllArgs (replaceOne i x expr) (i+1) xs 
+   
+         
+
+-----------------------------------------------
+
+-- embed expression in another one from the start category
+
+embedInStart :: [FuncWithArg] -> Map.Map MyType Expr -> Maybe Expr 
+embedInStart fss cs =
+  let currset = Map.toList cs 
+      nextset = Map.fromList $ concat [ if elem myt (getTypeArgs farg) 
+                     then connectWithArg (myt,exp) farg else [] 
+                        | (myt,exp) <- currset, farg <- fss]
+      nextmap = Map.union cs nextset
+      maybeExpr = Map.lookup startCateg nextset
+     in if isNothing maybeExpr then 
+               if Map.size nextmap == Map.size cs then Nothing --error $ "could't build " ++ show startCateg ++ "with " ++ show fss 
+                  else embedInStart fss nextmap
+       else return $ fromJust maybeExpr
+   where 
+      connectWithArg (myt,exp) farg = 
+             let ind = head $ elemIndices myt (getTypeArgs farg)
+              in [(getType farg, mkApp (getName farg) $ [mkMeta i | i <- [1..ind]] ++ [exp] ++ [mkMeta i | i <- [(ind + 1)..((length $ getTypeArgs farg) - 1)]])]
+               
+
+
+
+
+-----------------------------------------------
+{-
+updateConcMap :: Environ -> MyFunc -> Expr -> Environ
+updateConcMap env myf expr = 
+     Env (getTypeMap env) (Map.insert myf expr (getConcMap env)) (getSigs env) (getAll env)
+
+ 
+updateInterInstr :: Environ -> MyType -> FuncWithArg -> Environ
+updateInterInstr env myt myf  = 
+  let  ii = getSigs env
+       newInterInstr = 
+         maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
+      in Env (getTypeMap env) (getConcMap env) newInterInstr (getAll env)
+
+
+putSignatures :: Environ -> [FuncWithArg] -> Environ
+putSignatures env fss = 
+     Env (getTypeMap env) (getConcMap env) (mkSigs fss) (getAll env)
+      
+      
+updateEnv :: Environ -> FuncWithArg -> MyType -> Expr -> Environ 
+updateEnv env myf myt expr =  
+  let  ii = getSigs env
+       nn = getName myf
+       newInterInstr = 
+         maybe (Map.insert myt [myf] ii) (\x -> Map.insert myt (myf:x) ii) $ Map.lookup myt ii
+      in Env (getTypeMap env) (Map.insert nn expr (getConcMap env)) newInterInstr (getAll env)
+-}
+
+mkSigs :: [FuncWithArg] -> Map.Map MyType [FuncWithArg]
+mkSigs fss = Map.fromListWith (++) $ zip (map getType fss) (map (\x -> [x]) fss)
+
+
+
+{------------------------------------
+lang :: String 
+lang = "Eng"
+
+
+parseLang :: Language
+parseLang = fromJust $ readLanguage "ParseEng"
+
+
+parsePGFfile :: String
+parsePGFfile = "ParseEngAbs.pgf"
+------------------------------------}
+
+
+
+
+                 
+searchGoodTree :: Environ -> Expr -> [Expr] -> IO (Maybe (Expr,Expr))
+searchGoodTree env expr [] = return Nothing
+searchGoodTree env expr (e:es) = 
+     do val <- debugReplaceArgs expr e env
+        maybe (searchGoodTree env expr es) (\x -> return $ Just (x,e)) val 
+
+
+
+getNameExpr :: MyFunc -> Environ -> Maybe Expr
+getNameExpr myfunc env = 
+    let allfunc = filter (\x -> getName x == myfunc) $ getAll env
+            in 
+        if null allfunc then Nothing
+            else getExpr (head allfunc) env
+
+-- find an expression to generate where we have all the other elements available
+getExpr :: FuncWithArg -> Environ -> Maybe Expr 
+getExpr farg env =  
+  let tys = getTypeArgs farg
+      ctx = getSigs env 
+      lst = getConcTypes ctx tys 1
+    in if (all isJust lst) then  Just $ mkApp (getName farg) (map fromJust lst)
+            else  Nothing    
+     where getConcTypes context [] i = []
+           getConcTypes context (ty:types) i =  
+                let pos = Map.lookup ty context
+                   in 
+                    if isNothing pos  || (null $ fromJust pos) then [Nothing]                                                
+                          else  
+                             let mm = last $ fromJust pos
+                                 mmargs = getTypeArgs mm
+                                 newi = i + length mmargs - 1  
+                                 lst = getConcTypes (Map.insert ty (init $ (fromJust pos)) context) types (newi+1)
+                                  in                      
+                                  if (all isJust lst) then                     -- i..newi
+                                         (Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst 
+                                       else  [Nothing]
+      
+
+
+
+
+-- only covers simple expressions with meta variables, not the rest...
+isGeneralizationOf :: Expr -> Expr -> Bool
+isGeneralizationOf genExpr testExpr = 
+  if isMeta genExpr then True
+   else if isMeta testExpr then False
+    else let genUnwrap = unApp genExpr 
+             testUnwrap = unApp testExpr
+       in if isNothing genUnwrap || isNothing testUnwrap then False -- see if you can generalize here
+           else let (gencid, genargs) = fromJust genUnwrap 
+                    (testcid, testargs) = fromJust testUnwrap
+                in 
+                   (gencid == testcid) && (length genargs == length testargs)       
+                       && (and [isGeneralizationOf g t | (g,t) <- (zip genargs testargs)])
+
+{-do lst <- getConcTypes context types (i+1)
+     return $ mkMeta i : lst -} 
+
+debugReplaceArgs :: Expr -> Expr -> Environ -> IO (Maybe Expr)
+debugReplaceArgs aexpr cexpr env = 
+  if isNothing $ unApp aexpr then return Nothing
+       else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then return Nothing
+     else
+       let args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr
+           concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args
+         in startReplace 1 cexpr concExprs
+        where 
+          startReplace i cex []        = return $ Just cex
+          startReplace i cex (a:as)    = do val <- debugReplaceConc cex i a
+                                            maybe ( --do putStrLn $ "didn't find "++ showExpr [] a ++ " in " ++showExpr [] cexpr
+                                                       return Nothing) 
+                                                  (\x -> --do putStrLn $ "found it, the current expression is "++ showExpr [] x
+                                                            startReplace (i+1) x as) 
+                                                     val 
+                      
+debugReplaceConc :: Expr -> Int -> Expr -> IO (Maybe Expr)
+debugReplaceConc expr i e = 
+       let (newe,isThere) = searchArg expr 
+          in if isThere then return $ Just newe else return $ Nothing 
+     where   
+      searchArg e_  =  
+            if isGeneralizationOf e e_ then (mkMeta i, True)
+              else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args
+                                         in (mkApp cid (map  fst repargs), or $ map snd repargs)) $ unApp e_  
+ 
+
+{-
+-- replaceArgs : Original expression to parse (from abstract syntax) -> Concrete expression (parsed) 
+replaceArgs :: Expr -> Expr -> Environ -> Maybe Expr
+replaceArgs aexpr cexpr env =
+  if isNothing $ unApp aexpr then error $ "could't unwrap this "++ show aexpr 
+      else if any isNothing $ map unApp $ snd $ fromJust $ unApp aexpr then error $ "couldn't unwrap more this : "++ show aexpr
+  else 
+   let  args = map (fst.fromJust.unApp) $ snd $ fromJust $ unApp aexpr
+        concExprs = map (\x -> fromJust $ Map.lookup x $ getConcMap env) args
+          in startReplace 1 cexpr concExprs
+    where 
+      startReplace i cex []       = return cex 
+      startReplace i cex (a:as)   = maybe Nothing (\x -> startReplace (i+1) x as) $ replaceConc cex i a
+
+
+
+replaceConc :: Expr -> Int -> Expr -> Maybe Expr
+replaceConc expr i e = 
+       let (newe,isThere) = searchArg expr 
+          in if isThere then return newe else Nothing 
+     where   
+      searchArg e_  =  
+            if isGeneralizationOf e e_ then (mkMeta i, True)
+              else maybe (e_,False) (\(cid,args) -> let repargs = map searchArg args
+                                         in (mkApp cid (map  fst repargs), or $ map snd repargs)) $ unApp e_  
+
+
+
+writeResults :: Environ -> String -> IO ()
+writeResults env fileName = 
+   let cmap = getConcMap env
+       lincats = unlines $ map (\(x,y) -> "lincat " ++ showCId x ++ " = " ++ showCId y ++ " ; " ) $ Map.toList $ getTypeMap env 
+       sigs = unlines $ map 
+                  (\x -> let n = getName x 
+                             no = length $ getTypeArgs x
+                             oargs = unwords $ ("lin " ++ showCId n) : ["o"++show i | i <- [1..no]]     
+                         in (oargs ++ " = " ++ (simpleReplace $ showExpr [] $ fromJust $ Map.lookup n cmap) ++ " ; ")) $ concat $ Map.elems $ getSigs env
+    in 
+          writeFile fileName ("\n" ++ lincats ++ "\n\n" ++  sigs)  
+         
+
+simpleReplace :: String -> String 
+simpleReplace [] = []
+simpleReplace ('?':xs) = 'o' : simpleReplace xs
+simpleReplace (x:xs) = x : simpleReplace xs
+-}
+
+isMeta :: Expr -> Bool
+isMeta = isJust.unMeta 
+
+-- works with utf-8 characters also, as it seems
+
+
+mkFuncWithArg ::  ((CId,CId),[CId]) -> FuncWithArg
+mkFuncWithArg ((c1,c2),cids) = FuncWithArg c1 c2 cids
+
+
+---------------------------------------------------------------------------------
+
+initial :: TypeMap -> ConcMap -> [FuncWithArg] -> [FuncWithArg] -> Environ
+initial tm cm fss allfs = Env tm cm (mkSigs fss) allfs
+{-
+testInit :: [FuncWithArg] -> Environ
+testInit allfs = initial lTypes Map.empty [] allfs
+
+lTypes = Map.fromList [(mkCId "Comment", mkCId "S"),(mkCId "Item", mkCId "NP"), (mkCId "Kind", mkCId "CN"), (mkCId "Quality", mkCId "AP")]
+-}
+startCateg = mkCId "Comment"
+-- question about either to give the startcat or not ...
+
+
+
+
+
+----------------------------------------------------------------------------------------------------------
+{-
+main = 
+ do args <- getArgs
+    case args of 
+      [pgfFile] -> 
+         do pgf <- readPGF pgfFile
+            parsePGF <- readPGF parsePGFfile
+            fsWithArg <- forExample pgf
+            let funcsWithArg = map (map mkFuncWithArg) fsWithArg
+            let morpho = buildMorpho parsePGF parseLang
+            let fss = concat funcsWithArg
+            let fileName = takeWhile (/='.') pgfFile ++ lang ++ ".gf"
+            env <- start parsePGF pgf morpho (testInit fss) fss
+            putStrLn $ "Should I write the results to a file ? yes/no"
+            ans <-getLine 
+            if ans == "yes" then do writeResults env fileName
+                                    putStrLn $ "Wrote file " ++ fileName
+             else return ()  
+      _ ->  fail "usage : Testing <path-to-pgf> "
+
+
+  
+start :: PGF -> PGF -> Morpho -> Environ -> [FuncWithArg] -> IO Environ
+start parsePGF pgfFile morpho env lst = 
+  do putStrLn "Do you want examples from another language ? (no/concrete syntax name otherwise)"
+     ans1 <- getLine
+     putStrLn "Do you want testing mode ? (yes/no)"
+     ans2 <- getLine
+     case (ans1,ans2) of
+       ("no","no")    -> do putStrLn "no extra language, just the abstract syntax tree"
+                            interact env lst False Nothing 
+       (_,"no")       -> interact env lst False (readLanguage ans1)
+       ("no","yes")   -> do putStrLn "no extra language, just the abstract syntax tree"
+                            interact env lst True Nothing
+       (_,"yes")    -> interact env lst True (readLanguage ans1)
+       ("no",_)       -> do putStrLn "no extra language, just the abstract syntax tree"
+                            putStrLn $ "I assume you don't want the testing mode ... " 
+                            interact env lst False Nothing
+       (_,_)          -> do putStrLn $ "I assume you don't want the testing mode ... " 
+                            interact env lst False (readLanguage ans1)             
+  where 
+
+   interact environ [] func _ = return environ
+   interact environ (farg:fargs) boo otherLang = 
+             do 
+                maybeEnv <- basicInter farg otherLang environ boo
+                if isNothing maybeEnv then return environ
+                 else interact (fromJust maybeEnv) fargs boo otherLang                
+
+   basicInter farg js environ False = 
+       let e_ = getExpr farg environ in 
+        if isNothing e_ then return $ Just environ
+             else parseAndBuild farg js environ (getType farg) e_ Nothing 
+   basicInter farg js environ True = 
+        let (e_,e_test) = get2Expr farg environ in 
+         if isNothing e_ then return $ Just environ 
+          else if isNothing e_test then do putStrLn $ "not enough arguments "++ (showCId $ getName farg)
+                                           parseAndBuild farg js environ (getType farg) e_ Nothing  
+                    else parseAndBuild farg js environ (getType farg) e_ e_test
+
+-- . head . generateRandomFrom gen2 pgfFile
+   parseAndBuild farg js environ ty e_ e_test =
+           do let expr = fromJust e_
+              gen1 <- newStdGen
+              gen2 <- newStdGen
+              let newexpr = head $ generateRandomFrom gen1 pgfFile expr
+              let embeddedExpr = maybe "***" (showExpr [] ) (embedInStart (getAll environ) (Map.fromList [(ty,expr)])) 
+              let lexpr = if isNothing js then "" else "\n-- " ++ linearize pgfFile (fromJust js) newexpr ++ " --" 
+              putStrLn $ "Give an example for " ++ (showExpr [] expr)    
+                               ++ lexpr ++ "and now"
+                               ++ "\n\nas in " ++ embeddedExpr ++ "\n\n"
+              --
+              ex <- getLine 
+              if (ex == ":q") then return Nothing  
+                    else 
+                      let ctype = fromJust $ Map.lookup (getType farg) (getTypeMap environ) in
+                         do env' <- decypher farg ex expr environ (fromJust $ readType $ showCId ctype) e_test
+                            return (Just env')
+       
+   decypher farg ex expr environ ty e_test =  
+     --do putStrLn $ "We need to parse " ++ ex ++ " as " ++ show ctype
+        let pTrees = parse parsePGF (fromJust $ readLanguage "ParseEng") ty ex  in 
+             pickTree farg expr environ ex e_test pTrees 
+             
+ --  putStrLn $ "And now for testing, \n is this also correct yes/no \n ## " ++  (linearize parsePGF parseLang $ mapToResource newenv $ llin newenv e_test) ++ " ##"
+                                               
+   -- select the right tree among the options given by the parser 
+   pickTree farg expr environ ex e_test [] =  
+                let miswords = morphoMissing morpho (words ex) 
+                   in 
+                if null miswords then do putStrLn $ "all words known, but some syntactic construction is not covered by the grammar..."
+                                         return environ
+                    else do putStrLn $ "the following words are unknown, please add them to the lexicon: " ++ show miswords
+                            return environ
+   pickTree farg expr environ ex e_test [tree] = 
+                do val <- searchGoodTree environ expr [tree]  -- maybe order here after the probabilities for better precision
+                   maybe (do putStrLn $ "none of the trees is consistent with the rest of the grammar, please check arguments "
+                             return environ) 
+                         (\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
+                                              do putStrLn $ "the result is "++showExpr [] x
+                                                 newtestenv <- testTest newenv e_test -- question ? should it belong there - there is just one possibility of a tree... 
+                                                 return newenv) val
+   pickTree farg expr environ ex e_test parseTrees = 
+                do putStrLn $ "There is more than one possibility, do you want to choose the right tree yourself ? yes/no "
+                   putStr "  >"
+                   ans <- getLine
+                   if ans == "yes" then do pTree <- chooseRightTree parseTrees
+                                           processTree farg environ expr pTree e_test
+                     else processTree farg environ expr parseTrees e_test
+
+   -- introduce testing function, if it doesn't work, then reparse, take that tree
+   testTree envv e_test = return envv -- TO DO - add testing here
+   
+   testTest envv Nothing = return envv
+   testTest envv (Just exxpr) = testTree envv exxpr   
+ 
+
+   -- allows the user to pick his own tree
+   chooseRightTree trees = return trees -- TO DO - add something clever here     
+   
+   -- selects the tree from where one can abstract over the original arguments 
+   processTree farg environ expr lsTrees e_test =
+     let trmes = if length lsTrees == 1 then "the tree is not consistent " else "none of the trees is consistent " in
+     do val <- searchGoodTree environ expr lsTrees
+        maybe (do putStrLn $ trmes ++ "with the rest of the grammar, please check arguments! "
+                  return environ) 
+                         (\(x,newtree) -> let newenv = updateEnv environ farg (getType farg) x in
+                                              do putStrLn $ "the result is "++showExpr [] x
+                                                 newtestenv <- testTest newenv e_test 
+                                                 return newenv) val
+
+
+
+-------------------------------
+
+get2Expr :: FuncWithArg -> Environ -> (Maybe Expr, Maybe Expr)
+get2Expr farg env =
+  let tys = getTypeArgs farg
+      ctx = getSigs env
+      (lst1,lst2) = getConcTypes2 ctx tys 1
+      arg1 = if (all isJust lst1) then Just $ mkApp (getName farg) (map fromJust lst1) else Nothing
+      arg2 = if (all isJust lst2) then Just $ mkApp (getName farg) (map fromJust lst2) else Nothing
+   in if arg1 == arg2 then (arg1, Nothing)
+         else (arg1,arg2)
+  where 
+           getConcTypes2 context [] i = ([],[])
+           getConcTypes2 context (ty:types) i =  
+                let pos = Map.lookup ty context
+                   in 
+                    if isNothing pos  || (null $ fromJust pos) then ([Nothing],[Nothing])                                                
+                          else  
+                             let (mm,tt) = (last $ fromJust pos, head $ fromJust pos)
+                                 mmargs = getTypeArgs mm
+                                 newi = i + length mmargs - 1  
+                                 (lst1,lst2) = getConcTypes2 (Map.insert ty (init (fromJust pos)) context) types (newi+1)
+                                 ttargs = getTypeArgs tt
+                                 newtti = i + length ttargs - 1
+                                 fstArg = if (all isJust lst1) then               -- i..newi  
+                                             (Just $ mkApp (getName mm) [mkMeta j | j <- [1..(length mmargs)]]) : lst1 
+                                            else [Nothing]
+                                 sndArg = if (all isJust lst2) then 
+                                             (Just $ mkApp (getName tt) [mkMeta j | j <- [1..(length ttargs)]]) : lst2
+                                            else [Nothing]
+                              in 
+                                (fstArg,sndArg)   
+
+
+-}
+ 

src/example-based/ExampleService.hs

@@ -0,0 +1,128 @@
+module ExampleService(cgiMain,cgiMain',newPGFCache) where
+import System.Random(newStdGen)
+import System.FilePath((</>),makeRelative)
+import Data.Map(fromList)
+import Data.Char(isDigit)
+import Data.Maybe(fromJust)
+import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
+import PGF
+import GF.Compile.ToAPI
+import Network.CGI
+import Text.JSON
+import CGIUtils
+import Cache
+import qualified ExampleDemo as E
+
+newPGFCache = newCache readPGF
+
+
+cgiMain :: Cache PGF -> CGI CGIResult
+cgiMain = handleErrors . handleCGIErrors . cgiMain' "." "."
+
+cgiMain' root cwd cache =
+  do command <- getInp "command"
+     environ <- parseEnviron =<< getInp "state"
+     case command of
+       "possibilities"    -> doPossibilities environ
+       "provide_example"  -> doProvideExample root cwd cache environ
+       "abstract_example" -> doAbstractExample cwd cache environ
+       "test_function"    -> doTestFunction cwd cache environ
+       _ -> throwCGIError 400 ("Unknown command: "++command) []
+
+doPossibilities environ =
+  do example_environ <- parseEnviron =<< getInp "example_state"
+     outputJSONP (E.getNext environ example_environ)
+
+doProvideExample root cwd cache environ =
+  do Just lang <- readInput "lang"
+     fun <- getCId "fun"
+     parsePGF <- readParsePGF cwd cache
+     let adjpath path = root</>makeRelative "/" (makeRelative root cwd</>path)
+     pgf <- liftIO . readCache cache . adjpath =<< getInp "grammar"
+     gen <- liftIO newStdGen
+     let Just (e,s) = E.provideExample gen environ fun parsePGF pgf lang
+         res = (showExpr [] e,s)
+     liftIO $ logError $ "proveExample ... = "++show res
+     outputJSONP res
+
+doAbstractExample cwd cache environ =
+  do example <- getInp "input"
+     Just params <- readInput "params"
+     absstr <- getInp "abstract"
+     Just abs <- return $ readExpr absstr
+     liftIO $ logError $ "abstract = "++showExpr [] abs
+     Just cat <- readInput "cat"
+     let t = mkType [] cat []
+     parsePGF <- readParsePGF cwd cache
+     let lang:_ = languages parsePGF
+     ae <- liftIO $ abstractExample parsePGF environ lang t abs example
+     outputJSONP (fmap (\(e,_)->(exprToAPI (instExpMeta params e),e)) ae)
+
+abstractExample parsePGF env lang cat abs example =
+    E.searchGoodTree env abs (parse parsePGF lang cat example)
+
+doTestFunction cwd cache environ =
+  do fun <- getCId "fun"
+     parsePGF <- readParsePGF cwd cache
+     let lang:_ = languages parsePGF
+     Just txt <- return (E.testThis environ fun parsePGF lang)
+     outputJSONP txt
+
+getCId :: String -> CGI CId
+getCId name = maybe err return =<< fmap readCId (getInp name)
+  where err = throwCGIError 400 ("Bad "++name) []
+{-
+getLimit :: CGI Int
+getLimit = maybe err return =<< readInput "limit"
+  where err = throwCGIError 400 "Missing/bad limit" []
+-}
+
+readParsePGF cwd cache =
+    do parsepgf <- getInp "parser"
+       liftIO $ readCache cache (cwd</>parsepgf)
+
+parseEnviron s = do state <- liftIO $ readIO s
+                    return $ environ state
+
+getInp name = maybe err (return . UTF8.decodeString) =<< getInput name
+  where err = throwCGIError 400 ("Missing parameter: "++name) []
+
+
+instance JSON CId where
+    showJSON = showJSON . show
+    readJSON = (readResult =<<) . readJSON
+
+instance JSON Expr where
+   showJSON = showJSON . showExpr []
+   readJSON = (m2r . readExpr =<<) . readJSON
+
+m2r = maybe (Error "read failed") Ok
+
+readResult s = case reads s of
+                 (x,r):_ | lex r==[("","")] -> Ok x
+                 _ -> Error "read failed"
+
+--------------------------------------------------------------------------------
+--            cat  lincat  fun  lin       fun  cat    cat
+environ :: ([(CId, CId)],[(CId, Expr)],[((CId, CId), [CId])]) -> E.Environ
+environ (lincats,lins0,funs) =
+    E.initial (fromList lincats) concmap fs allfs
+  where
+    concmap = fromList lins
+    allfs = map E.mkFuncWithArg funs
+    fs = [E.mkFuncWithArg f | f@((fn,_),_)<-funs, fn `elem` cns]
+    cns = map fst lins
+    lins = filter (not . E.isMeta .snd) lins0
+
+
+instExpMeta :: [CId] -> Expr -> Expr
+instExpMeta ps = fromJust . readExpr . instMeta ps . showExpr []
+
+instMeta :: [CId] -> String -> String
+instMeta ps s =
+  case break (=='?') s of
+    (s1,'?':s2) ->
+       case span isDigit s2 of
+         (s21@(_:_),s22) -> s1++show (ps!!(read s21-1))++instMeta ps s22
+         ("",s22) -> s1++'?':instMeta ps s22
+    (_,_) -> s