Change Data.Text to String as a test, seemingly makes no difference.

Bul ✓
Cat ✗
Chi ✓
Dan ✓
Dut ✓
Eng ✓
Est ✓
Fin ✓
Fre ✗
Ger ✓
Hin ✓
Ita ✗
Jpn ✓
Lav ✓
Nor ✓
Pol ✓
Ron ✓
Snd ✗
Spa ✓
Swe ✓
Tha ✓
Urd ✓

Passed 18 | Failed 4 | Total 22

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

@@ -90,6 +90,6 @@ jobs:
         stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
         # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
 
-    - name: Test
-      run: |
-        stack test --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
+    # - name: Test
+    #   run: |
+    #     stack test --system-ghc

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

@@ -25,7 +25,7 @@ jobs:
 
     - name: Install cibuildwheel
       run: |
-        python -m pip install git+https://github.com/joerick/cibuildwheel.git@main
+        python -m pip install git+https://github.com/joerick/cibuildwheel.git@master
 
     - name: Install build tools for OSX
       if: startsWith(matrix.os, 'macos')

.gitignore

@@ -5,6 +5,7 @@
 *.jar
 *.gfo
 *.pgf
+*.lpgf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf
@@ -53,10 +54,6 @@ DATA_DIR
 
 stack*.yaml.lock
 
-# Output files for test suite
-*.out
-gf-tests.html
-
 # Generated documentation (not exhaustive)
 demos/index-numbers.html
 demos/resourcegrammars.html

README.md

@@ -30,16 +30,13 @@ GF particularly addresses four aspects of grammars:
 
 ## Compilation and installation
 
-The simplest way of installing GF from source is with the command:
+The simplest way of installing GF is with the command:
 ```
 cabal install
 ```
-or:
-```
-stack install
-```
 
-For more information, including links to precompiled binaries, see the [download page](http://www.grammaticalframework.org/download/index.html).
+For more details, see the [download page](http://www.grammaticalframework.org/download/index.html)
+and [developers manual](http://www.grammaticalframework.org/doc/gf-developers.html).
 
 ## About this repository
 

RELEASE.md

@@ -45,8 +45,6 @@ but the generated _artifacts_ must be manually attached to the release as _asset
 
 ### 4. Upload to Hackage
 
-In order to do this you will need to be added the [GF maintainers](https://hackage.haskell.org/package/gf/maintainers/) on Hackage.
-
 1. Run `make sdist`
 2. Upload the package, either:
     1. **Manually**: visit <https://hackage.haskell.org/upload> and upload the file `dist/gf-X.Y.tar.gz`

WebSetup.hs

@@ -26,14 +26,6 @@ import Distribution.PackageDescription(PackageDescription(..))
   so users won't see this message unless they check the log.)
 -}
 
--- | Notice about contrib grammars
-noContribMsg :: IO ()
-noContribMsg = putStr $ unlines
-  [ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
-  , "If you want them to be built, clone the following repository in the same directory as gf-core:"
-  , "https://github.com/GrammaticalFramework/gf-contrib.git"
-  ]
-
 example_grammars :: [(String, String, [String])] -- [(pgf, subdir, source modules)]
 example_grammars =
    [("Letter.pgf","letter",letterSrc)
@@ -58,8 +50,11 @@ buildWeb gf flags (pkg,lbi) = do
   contrib_exists <- doesDirectoryExist contrib_dir
   if contrib_exists
   then mapM_ build_pgf example_grammars
-  -- else noContribMsg
-  else return ()
+  else putStr $ unlines
+    [ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
+    , "If you want these example grammars to be built, clone this repository in the same top-level directory as GF:"
+    , "https://github.com/GrammaticalFramework/gf-contrib.git"
+    ]
   where
     gfo_dir = buildDir lbi </> "examples"
 

download/index-3.11.md

@@ -49,17 +49,15 @@ You will probably need to update the `PATH` environment variable to include your
 
 For more information, see [Using GF on Windows](https://www.grammaticalframework.org/~inari/gf-windows.html) (latest updated for Windows 10).
 
-## Installing the latest Hackage release (macOS, Linux, and WSL2 on Windows)
+## Installing the latest release from source
 
 [GF is on Hackage](http://hackage.haskell.org/package/gf), so under
 normal circumstances the procedure is fairly simple:
 
-1.  Install ghcup https://www.haskell.org/ghcup/
-2.  `ghcup install ghc 8.10.4`
-3.  `ghcup set ghc 8.10.4`
-4.  `cabal update`
-5.  On Linux: install some C libraries from your Linux distribution (see note below)
-6.  `cabal install gf-3.11`
+1.  Install a recent version of the [Haskell Platform](http://hackage.haskell.org/platform) (see note below)
+2.  `cabal update`
+3.  On Linux: install some C libraries from your Linux distribution (see note below)
+4.  `cabal install gf`
 
 You can also download the source code release from [GitHub](https://github.com/GrammaticalFramework/gf-core/releases),
 and follow the instructions below under **Installing from the latest developer source code**.
@@ -76,6 +74,17 @@ so you might want to add this directory to your path (in `.bash_profile` or simi
 PATH=$HOME/.cabal/bin:$PATH
 ```
 
+**Build tools**
+
+In order to compile GF you need the build tools **Alex** and **Happy**.
+These can be installed via Cabal, e.g.:
+
+```
+cabal install alex happy
+```
+
+or obtained by other means, depending on your OS.
+
 **Haskeline**
 
 GF uses [`haskeline`](http://hackage.haskell.org/package/haskeline), which

gf.cabal

@@ -14,7 +14,6 @@ maintainer: Thomas Hallgren
 tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
 
 data-dir: src
-extra-source-files: WebSetup.hs
 data-files:
   www/*.html
   www/*.css
@@ -72,7 +71,7 @@ flag c-runtime
   Description: Include functionality from the C run-time library (which must be installed already)
   Default:     False
 
-library
+Library
   default-language:    Haskell2010
   build-depends: base >= 4.6 && <5,
                  array,
@@ -87,7 +86,10 @@ library
                  -- For compatability with ghc < 8
                  -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
                  transformers-compat,
-                 ghc-prim
+                 ghc-prim,
+                 text,
+                 hashable,
+                 unordered-containers
   hs-source-dirs: src/runtime/haskell
 
   other-modules:
@@ -108,6 +110,7 @@ library
     PGF
     PGF.Internal
     PGF.Haskell
+    LPGF
 
   other-modules:
     PGF.Data
@@ -178,13 +181,14 @@ library
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Concrete
+    GF.Compile.Compute.ConcreteNew
     GF.Compile.Compute.Predef
     GF.Compile.Compute.Value
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
     GF.Compile.GeneratePMCFG
+    GF.Compile.GrammarToLPGF
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
     GF.Compile.Optimize
@@ -207,12 +211,14 @@ library
     GF.Compile.TypeCheck.Concrete
     GF.Compile.TypeCheck.ConcreteNew
     GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.RConcrete
     GF.Compile.TypeCheck.TC
     GF.Compile.Update
     GF.Data.BacktrackM
     GF.Data.ErrM
     GF.Data.Graph
     GF.Data.Graphviz
+    GF.Data.IntMapBuilder
     GF.Data.Relation
     GF.Data.Str
     GF.Data.Utilities
@@ -319,7 +325,7 @@ library
   if impl(ghc>=8.2)
     ghc-options: -fhide-source-paths
 
-executable gf
+Executable gf
   hs-source-dirs: src/programs
   main-is: gf-main.hs
   default-language:    Haskell2010
@@ -352,5 +358,403 @@ test-suite gf-tests
   main-is:        run.hs
   hs-source-dirs: testsuite
   build-depends:  base>=4.3 && <5, Cabal>=1.8, directory, filepath, process
-  build-tool-depends: gf:gf
   default-language:    Haskell2010
+
+test-suite lpgf
+  type: exitcode-stdio-1.0
+  main-is: test.hs
+  hs-source-dirs:
+    src/compiler
+    src/runtime/haskell
+    testsuite/lpgf
+  other-modules:
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF
+    GF.Command.Abstract
+    GF.Command.CommandInfo
+    GF.Command.Commands
+    GF.Command.CommonCommands
+    GF.Command.Help
+    GF.Command.Importing
+    GF.Command.Interpreter
+    GF.Command.Messages
+    GF.Command.Parse
+    GF.Command.SourceCommands
+    GF.Command.TreeOperations
+    GF.Compile
+    GF.Compile.CFGtoPGF
+    GF.Compile.CheckGrammar
+    GF.Compile.Compute.ConcreteNew
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
+    GF.Compile.ConcreteToHaskell
+    GF.Compile.ExampleBased
+    GF.Compile.Export
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToCanonical
+    GF.Compile.GrammarToLPGF
+    GF.Compile.GrammarToPGF
+    GF.Compile.Multi
+    GF.Compile.Optimize
+    GF.Compile.PGFtoHaskell
+    GF.Compile.PGFtoJava
+    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.ToAPI
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.RConcrete
+    GF.Compile.TypeCheck.TC
+    GF.Compile.Update
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compiler
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.Graph
+    GF.Data.Graphviz
+    GF.Data.IntMapBuilder
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Data.XML
+    GF.Grammar
+    GF.Grammar.Analyse
+    GF.Grammar.Binary
+    GF.Grammar.BNFC
+    GF.Grammar.Canonical
+    GF.Grammar.CanonicalJSON
+    GF.Grammar.CFG
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Parser
+    GF.Grammar.PatternMatch
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.ShowTerm
+    GF.Grammar.Unify
+    GF.Grammar.Values
+    GF.Haskell
+    GF.Infra.BuildInfo
+    GF.Infra.CheckM
+    GF.Infra.Concurrency
+    GF.Infra.Dependencies
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.SIO
+    GF.Infra.UseIO
+    GF.Interactive
+    GF.JavaScript.AbsJS
+    GF.JavaScript.PrintJS
+    GF.Main
+    GF.Quiz
+    GF.Speech.CFGToFA
+    GF.Speech.FiniteState
+    GF.Speech.GSL
+    GF.Speech.JSGF
+    GF.Speech.PGFToCFG
+    GF.Speech.PrRegExp
+    GF.Speech.RegExp
+    GF.Speech.SISR
+    GF.Speech.SLF
+    GF.Speech.SRG
+    GF.Speech.SRGS_ABNF
+    GF.Speech.SRGS_XML
+    GF.Speech.VoiceXML
+    GF.Support
+    GF.System.Catch
+    GF.System.Concurrency
+    GF.System.Console
+    GF.System.Directory
+    GF.System.Process
+    GF.System.Signal
+    GF.Text.Clitics
+    GF.Text.Coding
+    GF.Text.Lexing
+    GF.Text.Pretty
+    GF.Text.Transliterations
+    LPGF
+    PGF
+    PGF.Binary
+    PGF.ByteCode
+    PGF.CId
+    PGF.Data
+    PGF.Expr
+    PGF.Forest
+    PGF.Generate
+    PGF.Internal
+    PGF.Linearize
+    PGF.Macros
+    PGF.Morphology
+    PGF.OldBinary
+    PGF.Optimize
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Printer
+    PGF.Probabilistic
+    PGF.Tree
+    PGF.TrieMap
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Utilities
+    PGF.VisualizeTree
+    Paths_gf
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+  build-depends:
+    ansi-terminal,
+    array,
+    base>=4.6 && <5,
+    bytestring,
+    containers,
+    directory,
+    filepath,
+    ghc-prim,
+    hashable,
+    haskeline,
+    json,
+    mtl,
+    parallel>=3,
+    pretty,
+    process,
+    random,
+    terminfo,
+    text,
+    time,
+    transformers-compat,
+    unix,
+    unordered-containers,
+    utf8-string
+  default-language: Haskell2010
+
+benchmark lpgf-bench
+  type: exitcode-stdio-1.0
+  main-is: bench.hs
+  hs-source-dirs:
+    src/compiler
+    src/runtime/haskell
+    testsuite/lpgf
+  other-modules:
+    Data.Binary
+    Data.Binary.Builder
+    Data.Binary.Get
+    Data.Binary.IEEE754
+    Data.Binary.Put
+    GF
+    GF.Command.Abstract
+    GF.Command.CommandInfo
+    GF.Command.Commands
+    GF.Command.CommonCommands
+    GF.Command.Help
+    GF.Command.Importing
+    GF.Command.Interpreter
+    GF.Command.Messages
+    GF.Command.Parse
+    GF.Command.SourceCommands
+    GF.Command.TreeOperations
+    GF.Compile
+    GF.Compile.CFGtoPGF
+    GF.Compile.CheckGrammar
+    GF.Compile.Compute.ConcreteNew
+    GF.Compile.Compute.Predef
+    GF.Compile.Compute.Value
+    GF.Compile.ConcreteToHaskell
+    GF.Compile.ExampleBased
+    GF.Compile.Export
+    GF.Compile.GenerateBC
+    GF.Compile.GeneratePMCFG
+    GF.Compile.GetGrammar
+    GF.Compile.GrammarToCanonical
+    GF.Compile.GrammarToLPGF
+    GF.Compile.GrammarToPGF
+    GF.Compile.Multi
+    GF.Compile.Optimize
+    GF.Compile.PGFtoHaskell
+    GF.Compile.PGFtoJS
+    GF.Compile.PGFtoJSON
+    GF.Compile.PGFtoJava
+    GF.Compile.PGFtoProlog
+    GF.Compile.PGFtoPython
+    GF.Compile.ReadFiles
+    GF.Compile.Rename
+    GF.Compile.SubExOpt
+    GF.Compile.Tags
+    GF.Compile.ToAPI
+    GF.Compile.TypeCheck.Abstract
+    GF.Compile.TypeCheck.ConcreteNew
+    GF.Compile.TypeCheck.Primitives
+    GF.Compile.TypeCheck.RConcrete
+    GF.Compile.TypeCheck.TC
+    GF.Compile.Update
+    GF.CompileInParallel
+    GF.CompileOne
+    GF.Compiler
+    GF.Data.BacktrackM
+    GF.Data.ErrM
+    GF.Data.Graph
+    GF.Data.Graphviz
+    GF.Data.IntMapBuilder
+    GF.Data.Operations
+    GF.Data.Relation
+    GF.Data.Str
+    GF.Data.Utilities
+    GF.Data.XML
+    GF.Grammar
+    GF.Grammar.Analyse
+    GF.Grammar.BNFC
+    GF.Grammar.Binary
+    GF.Grammar.CFG
+    GF.Grammar.Canonical
+    GF.Grammar.CanonicalJSON
+    GF.Grammar.EBNF
+    GF.Grammar.Grammar
+    GF.Grammar.Lexer
+    GF.Grammar.Lockfield
+    GF.Grammar.Lookup
+    GF.Grammar.Macros
+    GF.Grammar.Parser
+    GF.Grammar.PatternMatch
+    GF.Grammar.Predef
+    GF.Grammar.Printer
+    GF.Grammar.ShowTerm
+    GF.Grammar.Unify
+    GF.Grammar.Values
+    GF.Haskell
+    GF.Infra.BuildInfo
+    GF.Infra.CheckM
+    GF.Infra.Concurrency
+    GF.Infra.Dependencies
+    GF.Infra.GetOpt
+    GF.Infra.Ident
+    GF.Infra.Location
+    GF.Infra.Option
+    GF.Infra.SIO
+    GF.Infra.UseIO
+    GF.Interactive
+    GF.JavaScript.AbsJS
+    GF.JavaScript.PrintJS
+    GF.Main
+    GF.Quiz
+    GF.Speech.CFGToFA
+    GF.Speech.FiniteState
+    GF.Speech.GSL
+    GF.Speech.JSGF
+    GF.Speech.PGFToCFG
+    GF.Speech.PrRegExp
+    GF.Speech.RegExp
+    GF.Speech.SISR
+    GF.Speech.SLF
+    GF.Speech.SRG
+    GF.Speech.SRGS_ABNF
+    GF.Speech.SRGS_XML
+    GF.Speech.VoiceXML
+    GF.Support
+    GF.System.Catch
+    GF.System.Concurrency
+    GF.System.Console
+    GF.System.Directory
+    GF.System.Process
+    GF.System.Signal
+    GF.Text.Clitics
+    GF.Text.Coding
+    GF.Text.Lexing
+    GF.Text.Pretty
+    GF.Text.Transliterations
+    LPGF
+    PGF
+    PGF.Binary
+    PGF.ByteCode
+    PGF.CId
+    PGF.Data
+    PGF.Expr
+    PGF.Expr
+    PGF.Forest
+    PGF.Generate
+    PGF.Internal
+    PGF.Linearize
+    PGF.Macros
+    PGF.Morphology
+    PGF.OldBinary
+    PGF.Optimize
+    PGF.Paraphrase
+    PGF.Parse
+    PGF.Printer
+    PGF.Probabilistic
+    PGF.Tree
+    PGF.TrieMap
+    PGF.Type
+    PGF.TypeCheck
+    PGF.Utilities
+    PGF.VisualizeTree
+    PGF2
+    PGF2.Expr
+    PGF2.Type
+    PGF2.FFI
+    Paths_gf
+  if flag(interrupt)
+    cpp-options: -DUSE_INTERRUPT
+    other-modules: GF.System.UseSignal
+  else
+    other-modules: GF.System.NoSignal
+
+  hs-source-dirs:
+    src/runtime/haskell-bind
+  other-modules:
+    PGF2
+    PGF2.FFI
+    PGF2.Expr
+    PGF2.Type
+  build-tools:     hsc2hs
+  extra-libraries: pgf gu
+  c-sources:       src/runtime/haskell-bind/utils.c
+  cc-options:      -std=c99
+
+  build-depends:
+    ansi-terminal,
+    array,
+    base>=4.6 && <5,
+    bytestring,
+    containers,
+    deepseq,
+    directory,
+    filepath,
+    ghc-prim,
+    hashable,
+    haskeline,
+    json,
+    mtl,
+    parallel>=3,
+    pretty,
+    process,
+    random,
+    terminfo,
+    text,
+    time,
+    transformers-compat,
+    unix,
+    unordered-containers,
+    utf8-string
+  default-language: Haskell2010

index.html

@@ -228,10 +228,6 @@ least one, it may help you to get a first idea of what GF is.
     <h2>News</h2>
 
     <dl class="row">
-      <dt class="col-sm-3 text-center text-nowrap">2021-05-05</dt>
-      <dd class="col-sm-9">
-        <a href="https://cloud.grammaticalframework.org/wordnet/">GF WordNet</a> now supports languages for which there are no other WordNets. New additions: Afrikaans, German, Korean, Maltese, Polish, Somali, Swahili.
-      </dd>
       <dt class="col-sm-3 text-center text-nowrap">2021-03-01</dt>
       <dd class="col-sm-9">
         <a href="//school.grammaticalframework.org/2020/">Seventh GF Summer School</a>, in Singapore and online, 26 July &ndash; 8 August 2021.

src/compiler/GF/Command/Commands.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 module GF.Command.Commands (
   PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
   options,flags,
@@ -741,7 +741,7 @@ pgfCommands = Map.fromList [
                                      Nothing   -> do putStrLn ("unknown category of function identifier "++show id)
                                                      return void
          [e]         -> case inferExpr pgf e of
-                          Left tcErr   -> errorWithoutStackTrace $ render (ppTcError tcErr)
+                          Left tcErr   -> error $ render (ppTcError tcErr)
                           Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
                                              putStrLn ("Type:        "++showType [] ty)
                                              putStrLn ("Probability: "++show (probTree pgf e))
@@ -1019,7 +1019,3 @@ stanzas = map unlines . chop . lines where
   chop ls = case break (=="") ls of
     (ls1,[])  -> [ls1]
     (ls1,_:ls2) -> ls1 : chop ls2
-
-#if !(MIN_VERSION_base(4,9,0))
-errorWithoutStackTrace = error
-#endif

src/compiler/GF/Command/CommonCommands.hs

@@ -15,7 +15,6 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
 import GF.Text.Pretty
 import GF.Text.Transliterations
 import GF.Text.Lexing(stringOp,opInEnv)
-import Data.Char (isSpace)
 
 import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
 
@@ -171,8 +170,7 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
        restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
        fmap fromString $ restricted $ readFile tmpo,
        -}
-       fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
-
+       fmap fromString . restricted . readShellProcess syst $ toString arg,
      flags = [
        ("command","the system command applied to the argument")
        ],

src/compiler/GF/Command/SourceCommands.hs

@@ -18,8 +18,8 @@ import GF.Grammar.Parser (runP, pExp)
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
-import GF.Compile.Compute.Concrete(normalForm,resourceValues)
-import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
+import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues)
+import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
 import GF.Infra.Dependencies(depGraph)
 import GF.Infra.CheckM(runCheck)
 
@@ -259,7 +259,7 @@ checkComputeTerm os sgr t =
      ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
                                 inferLType sgr [] t
      let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-         t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
+         t1 = CN.normalForm (CN.resourceValues opts sgr) (L NoLoc identW) t
          t2 = evalStr t1
      checkPredefError t2
   where

src/compiler/GF/Compile.hs

@@ -1,6 +1,7 @@
-module GF.Compile (compileToPGF, link, batchCompile, srcAbsName) where
+module GF.Compile (compileToPGF, compileToLPGF, link, linkl, batchCompile, srcAbsName) where
 
 import GF.Compile.GrammarToPGF(mkCanon2pgf)
+import GF.Compile.GrammarToLPGF(mkCanon2lpgf)
 import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles,
                             importsOfModule)
 import GF.CompileOne(compileOne)
@@ -14,7 +15,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,(<=<),filterM,liftM)
+import Control.Monad(foldM,when,(<=<),filterM)
 import GF.System.Directory(doesFileExist,getModificationTime)
 import System.FilePath((</>),isRelative,dropFileName)
 import qualified Data.Map as Map(empty,insert,elems) --lookup
@@ -24,12 +25,16 @@ import GF.Text.Pretty(render,($$),(<+>),nest)
 
 import PGF.Internal(optimizePGF)
 import PGF(PGF,defaultProbabilities,setProbabilities,readProbabilitiesFromFile)
+import LPGF(LPGF)
 
 -- | Compiles a number of source files and builds a 'PGF' structure for them.
 -- This is a composition of 'link' and 'batchCompile'.
 compileToPGF :: Options -> [FilePath] -> IOE PGF
 compileToPGF opts fs = link opts . snd =<< batchCompile opts fs
 
+compileToLPGF :: Options -> [FilePath] -> IOE LPGF
+compileToLPGF opts fs = linkl opts . snd =<< batchCompile opts fs
+
 -- | Link a grammar into a 'PGF' that can be used to 'PGF.linearize' and
 -- 'PGF.parse' with the "PGF" run-time system.
 link :: Options -> (ModuleName,Grammar) -> IOE PGF
@@ -39,9 +44,17 @@ link opts (cnc,gr) =
     pgf <- mkCanon2pgf opts gr abs
     probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
     when (verbAtLeast opts Normal) $ putStrE "OK"
-    return $ setProbabilities probs 
+    return $ setProbabilities probs
            $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
 
+-- | Link a grammar into a 'LPGF' that can be used for linearization only.
+linkl :: Options -> (ModuleName,Grammar) -> IOE LPGF
+linkl opts (cnc,gr) =
+  putPointE Normal opts "linking ... " $ do
+    let abs = srcAbsName gr cnc
+    lpgf <- mkCanon2lpgf opts gr abs
+    return lpgf
+
 -- | Returns the name of the abstract syntax corresponding to the named concrete syntax
 srcAbsName gr cnc = err (const cnc) id $ abstractOfConcrete gr cnc
 

src/compiler/GF/Compile/CheckGrammar.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/11 23:24:33 $
+-- > CVS $Date: 2005/11/11 23:24:33 $ 
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.31 $
 --
@@ -27,9 +27,9 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
-import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
-import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
+import GF.Compile.TypeCheck.RConcrete
+import qualified GF.Compile.TypeCheck.ConcreteNew as CN
+import qualified GF.Compile.Compute.ConcreteNew as CN
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -74,9 +74,9 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
      let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
      let incld c   = Set.member c (Set.fromList incl)
      let illegal c = Set.member c (Set.fromList excl)
-     let illegals = [(f,is) |
+     let illegals = [(f,is) | 
            (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
-     case illegals of
+     case illegals of 
        [] -> return ()
        cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
                          nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
@@ -92,12 +92,12 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
 
   -- check that all abstract constants are in concrete; build default lin and lincats
   jsc <- foldM checkAbs jsc (Map.toList jsa)
-
+  
   return (cm,cnc{jments=jsc})
   where
    checkAbs js i@(c,info) =
      case info of
-       AbsFun (Just (L loc ty)) _ _ _
+       AbsFun (Just (L loc ty)) _ _ _ 
            -> do let mb_def = do
                        let (cxt,(_,i),_) = typeForm ty
                        info <- lookupIdent i js
@@ -136,11 +136,11 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
            checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
            return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
        _ -> return js
-
+     
    checkCnc js (c,info) =
      case info of
        CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L _ 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
@@ -159,14 +159,14 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
        _ -> return $ Map.insert c info js
 
 
--- | General Principle: only Just-values are checked.
+-- | 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" $
+    AbsCat (Just (L loc cont)) -> 
+      mkCheck loc "the category" $ 
         checkContext gr cont
 
     AbsFun (Just (L loc typ0)) ma md moper -> do
@@ -181,7 +181,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
-                Just (L loc typ) -> chIn loc "linearization type of" $
+                Just (L loc typ) -> chIn loc "linearization type of" $ 
                                      (if False --flag optNewComp opts
                                         then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
                                                 typ  <- computeLType gr [] typ
@@ -191,19 +191,19 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
                                                 return (Just (L loc typ)))
                 Nothing          -> return Nothing
       mdef <- case (mty,mdef) of
-                (Just (L _ typ),Just (L loc def)) ->
+                (Just (L _ typ),Just (L loc def)) -> 
                     chIn loc "default linearization of" $ do
                        (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
                        return (Just (L loc def))
                 _ -> return Nothing
       mref <- case (mty,mref) of
-                (Just (L _ typ),Just (L loc ref)) ->
+                (Just (L _ typ),Just (L loc ref)) -> 
                     chIn loc "reference linearization of" $ do
                        (ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
                        return (Just (L loc ref))
                 _ -> return Nothing
       mpr  <- case mpr of
-                (Just (L loc t)) ->
+                (Just (L loc t)) -> 
                     chIn loc "print name of" $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
@@ -212,13 +212,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
 
     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))
               _ -> return mt
       mpr  <- case mpr of
-                (Just (L loc t)) ->
+                (Just (L loc t)) -> 
                     chIn loc "print name of" $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
@@ -251,16 +251,16 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
       tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
       tysts0 <- lookupOverload gr (m,c)  -- check against inherited ones too
-      tysts1 <- mapM (uncurry $ flip (checkLType gr []))
+      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 $
+      checkUniq $ 
         sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
       return (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do
-      ts <- chIn loc "parameter type" $
+      ts <- chIn loc "parameter type" $ 
               liftM concat $ mapM mkPar pcs
       return (ResParam (Just (L loc pcs)) (Just ts))
 
@@ -274,9 +274,9 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
        return $ map (mkApp (QC (m,f))) vs
 
    checkUniq xss = case xss of
-     x:y:xs
+     x:y:xs 
       | x == y    -> checkError $ "ambiguous for type" <+>
-                                  ppType (mkFunType (tail x) (head x))
+                                  ppType (mkFunType (tail x) (head x))  
       | otherwise -> checkUniq $ y:xs
      _ -> return ()
 
@@ -294,7 +294,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
        t' <- compAbsTyp ((x,Vr x):g) t
        return $ Prod b x a' t'
      Abs _ _ _ -> return t
-     _ -> composOp (compAbsTyp g) t
+     _ -> composOp (compAbsTyp g) t  
 
 
 -- | for grammars obtained otherwise than by parsing ---- update!!

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

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

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

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

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

@@ -12,8 +12,8 @@ data Value
   | 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
+  | VAbs BindType Ident Binding -- used in Compute.ConcreteNew
+  | VProd BindType Value Ident Binding -- used in Compute.ConcreteNew
   | VInt Int
   | VFloat Double
   | VString String
@@ -47,10 +47,10 @@ type Env = [(Ident,Value)]
 
 -- | Predefined functions
 data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
-                | ToLower | IsUpper | Length | Plus | EqInt | LessInt
+                | ToLower | IsUpper | Length | Plus | EqInt | LessInt 
              {- | Show | Read | ToStr | MapStr | EqVal -}
                 | Error | Trace
                 -- Canonical values below:
-                | PBool | PFalse | PTrue | Int | Float | Ints | NonExist
+                | 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

@@ -7,7 +7,7 @@ import GF.Text.Pretty
 --import GF.Grammar.Predef(cPredef,cInts)
 --import GF.Compile.Compute.Predef(predef)
 --import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
+import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
 import GF.Infra.Option
 import GF.Haskell as H
 import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
      | let Grammar abstr cncs = grammar2canonical opts absname gr,
        cncmod<-cncs,
        let ModId name = concName cncmod
-           filename = showRawIdent name ++ ".hs" :: FilePath
+           filename = name ++ ".hs" :: FilePath
   ]
 
 -- | Generate Haskell code for the given concrete module.
@@ -53,7 +53,7 @@ concrete2haskell opts
     labels = S.difference (S.unions (map S.fromList recs)) common_labels
     common_records = S.fromList [[label_s]]
     common_labels = S.fromList [label_s]
-    label_s = LabelId (rawIdentS "s")
+    label_s = LabelId "s"
 
     signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
       where
@@ -69,7 +69,7 @@ concrete2haskell opts
       where
      --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
        allcats = S.fromList [c | CatDef c _<-cats]
-
+      
     gId :: ToIdent i => i -> Ident
     gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
           . toIdent
@@ -116,7 +116,7 @@ concrete2haskell opts
               where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
             StrType -> tcon0 (identS "Str")
             TableType pt lt -> Fun (ppT pt) (ppT lt)
---          TupleType lts ->
+--          TupleType lts -> 
 
     lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
 
@@ -126,7 +126,7 @@ concrete2haskell opts
     linDefs = map eqn . sortOn fst . map linDef
       where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
 
-    linDef (LinDef f xs rhs0) =
+    linDef (LinDef f xs rhs0) = 
         (cat,(linfunName cat,(lhs,rhs)))
       where
         lhs = [ConP (aId f) (map VarP abs_args)]
@@ -144,7 +144,7 @@ concrete2haskell opts
           where
             vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
             env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
-
+            
         letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
           (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
 
@@ -187,7 +187,7 @@ concrete2haskell opts
 
         pId p@(ParamId s) =
           if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
-
+          
         table cs =
             if all (null.patVars) ps
             then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
@@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where
 
 -- | Record subtyping is converted into explicit coercions in Haskell
 coerce env ty t =
-  case (ty,t) of
+  case (ty,t) of 
     (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
     (TableType ti tv,TableValue _ cs) ->
       TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
     (RecordType rt,RecordValue r) ->
       RecordValue [RecordRow l (coerce env ft f) |
-                     RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
+                     RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
     (RecordType rt,VarValue x)->
       case lookup x env of
         Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
@@ -334,17 +334,18 @@ coerce env ty t =
     _ -> t
   where
     app f ts = ParamConstant (Param f ts) -- !! a hack
-    to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
+    to_rcon = ParamId . Unqual . to_rcon' . labels
 
 patVars p = []
 
-labels r = [l | RecordRow l _ <- r]
+labels r = [l|RecordRow l _<-r]
 
 proj = Var . identS . proj'
-proj' (LabelId l) = "proj_" ++ showRawIdent l
+proj' (LabelId l) = "proj_"++l
 rcon = Var . rcon'
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
+rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
+
 to_rcon' = ("to_"++) . rcon_name
 
 recordType ls =
@@ -399,17 +400,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
 
 class ToIdent i where toIdent :: i -> Ident
 
-instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
-instance ToIdent PredefId where toIdent (PredefId s) = identC s
-instance ToIdent CatId   where toIdent (CatId s) = identC s
-instance ToIdent C.FunId where toIdent (FunId s) = identC s
-instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
+instance ToIdent PredefId where toIdent (PredefId s) = identS s
+instance ToIdent CatId   where toIdent (CatId s) = identS s
+instance ToIdent C.FunId where toIdent (FunId s) = identS s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
 
-qIdentC = identS . unqual
+qIdentS = identS . unqual
 
-unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
-unqual (Unqual n) = showRawIdent n
+unqual (Qual (ModId m) n) = m++"_"++n
+unqual (Unqual n) = n
 
 instance ToIdent VarId where
   toIdent Anonymous = identW
-  toIdent (VarId s) = identC s
+  toIdent (VarId s) = identS s

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -25,7 +25,7 @@ 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 GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -82,7 +82,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
                           (goB b1 CNil [])
                           (pres,pargs)
       pmcfg      = getPMCFG pmcfgEnv1
-
+      
       stats      = let PMCFG prods funs = pmcfg
                        (s,e)            = bounds funs
                        !prods_cnt       = length prods
@@ -103,7 +103,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
           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))
+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
@@ -162,7 +162,7 @@ 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)
+                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) 
                                     (getStrPaths schema)))
   where
     getStrPaths :: Schema Identity s c -> [Path]
@@ -243,7 +243,7 @@ choices nr path = do (args,_) <- get
                                                                                                                     | (value,index) <- values])
     descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)
 
-    updateEnv path value gr c (args,seq) =
+    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"
@@ -606,7 +606,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do
                                                        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

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -6,35 +6,31 @@ module GF.Compile.GrammarToCanonical(
        ) where
 import Data.List(nub,partition)
 import qualified Data.Map as M
-import Data.Maybe(fromMaybe)
 import qualified Data.Set as S
 import GF.Data.ErrM
 import GF.Text.Pretty
-import GF.Grammar.Grammar as G
+import GF.Grammar.Grammar
 import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
-import GF.Infra.Option(Options,optionsPGF)
+import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
+import GF.Infra.Option(Options, optionsPGF)
 import PGF.Internal(Literal(..))
-import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
+import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
 import GF.Grammar.Canonical as C
-import System.FilePath ((</>), (<.>))
-import qualified Debug.Trace as T
-
+import Debug.Trace
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
-grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
+grammar2canonical :: Options -> ModuleName -> SourceGrammar -> C.Grammar
 grammar2canonical opts absname gr =
    Grammar (abstract2canonical absname gr)
            (map snd (concretes2canonical opts absname gr))
 
 -- | Generate Canonical code for the named abstract syntax
-abstract2canonical :: ModuleName -> G.Grammar -> Abstract
 abstract2canonical absname gr =
     Abstract (modId absname) (convFlags gr absname) cats funs
   where
@@ -49,7 +45,6 @@ abstract2canonical absname gr =
     convHypo (bt,name,t) =
       case typeForm t of
         ([],(_,cat),[]) -> gId cat -- !!
-        tf -> error $ "abstract2canonical convHypo: " ++ show tf
 
     convType t =
       case typeForm t of
@@ -60,24 +55,23 @@ abstract2canonical absname gr =
 
     convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
 
+
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
-concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
 concretes2canonical opts absname gr =
   [(cncname,concrete2canonical gr cenv absname cnc cncmod)
      | let cenv = resourceValues opts gr,
        cnc<-allConcretes gr absname,
-       let cncname = "canonical" </> render cnc <.> "gf"
+       let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
            Ok cncmod = lookupModule gr cnc
   ]
 
 -- | Generate Canonical GF for the given concrete module.
-concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
 concrete2canonical gr cenv absname cnc modinfo =
   Concrete (modId cnc) (modId absname) (convFlags gr cnc)
       (neededParamTypes S.empty (params defs))
-      [lincat | (_,Left lincat) <- defs]
-      [lin | (_,Right lin) <- defs]
+      [lincat|(_,Left lincat)<-defs]
+      [lin|(_,Right lin)<-defs]
   where
     defs = concatMap (toCanonical gr absname cenv) .
            M.toList $
@@ -92,7 +86,6 @@ concrete2canonical gr cenv absname cnc modinfo =
         else let ((got,need),def) = paramType gr q
              in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
-toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
 toCanonical gr absname cenv (name,jment) =
   case jment of
     CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -105,8 +98,7 @@ toCanonical gr absname cenv (name,jment) =
       where
         tts = tableTypes gr [e']
 
-        e' = cleanupRecordFields lincat $
-             unAbs (length params) $
+        e' = unAbs (length params) $
              nf loc (mkAbs params (mkApp def (map Vr args)))
         params = [(b,x)|(b,x,_)<-ctx]
         args = map snd params
@@ -117,12 +109,12 @@ toCanonical gr absname cenv (name,jment) =
     _ -> []
   where
     nf loc = normalForm cenv (L loc name)
+--  aId n = prefixIdent "A." (gId n)
 
     unAbs 0 t = t
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t
 
-tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
 tableTypes gr ts = S.unions (map tabtys ts)
   where
     tabtys t =
@@ -131,7 +123,6 @@ tableTypes gr ts = S.unions (map tabtys ts)
         T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
         _ -> collectOp tabtys t
 
-paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
 paramTypes gr t =
   case t of
     RecType fs -> S.unions (map (paramTypes gr.snd) fs)
@@ -150,26 +141,11 @@ paramTypes gr t =
                  Ok (_,ResParam {}) -> S.singleton q
                  _ -> ignore
 
-    ignore = T.trace ("Ignore: " ++ show t) S.empty
+    ignore = trace ("Ignore: "++show t) S.empty
 
--- | Filter out record fields from definitions which don't appear in lincat.
-cleanupRecordFields :: G.Type -> Term -> Term
-cleanupRecordFields (RecType ls) (R as) =
-  let defnFields = M.fromList ls
-  in R
-      [ (lbl, (mty, t'))
-      | (lbl, (mty, t)) <- as
-      , M.member lbl defnFields
-      , let Just ty = M.lookup lbl defnFields
-      , let t' = cleanupRecordFields ty t
-      ]
-cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
-cleanupRecordFields _ t = t
 
-convert :: G.Grammar -> Term -> LinValue
 convert gr = convert' gr []
 
-convert' :: G.Grammar -> [Ident] -> Term -> LinValue
 convert' gr vs = ppT
   where
     ppT0 = convert' gr vs
@@ -187,20 +163,20 @@ convert' gr vs = ppT
         S t p -> selection (ppT t) (ppT p)
         C t1 t2 -> concatValue (ppT t1) (ppT t2)
         App f a -> ap (ppT f) (ppT a)
-        R r -> RecordValue (fields (sortRec r))
+        R r -> RecordValue (fields r)
         P t l -> projection (ppT t) (lblId l)
         Vr x -> VarValue (gId x)
         Cn x -> VarValue (gId x) -- hmm
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
         EInt n -> LiteralValue (IntConstant n)
-        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
-        QC (m,n) -> ParamConstant (Param (gQId m n) [])
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
+        QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
         K s -> LiteralValue (StrConstant s)
         Empty -> LiteralValue (StrConstant "")
         FV ts -> VariantValue (map ppT ts)
         Alts t' vs -> alts vs (ppT t')
-        _ -> error $ "convert' ppT: " ++ show t
+        _ -> error $ "convert' "++show t
 
     ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
@@ -213,12 +189,12 @@ convert' gr vs = ppT
         Ok ALL_CAPIT  -> p "ALL_CAPIT"
         _ -> VarValue (gQId cPredef n) -- hmm
       where
-       p = PredefValue . PredefId . rawIdentS
+       p = PredefValue . PredefId
 
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
-        PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
+        PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
         PR r -> RecordPattern (fields r) {-
         PW -> WildPattern
         PV x -> VarP x
@@ -227,7 +203,6 @@ convert' gr vs = ppT
         PFloat x -> Lit (show x)
         PT _ p -> ppP p
         PAs x p -> AsP x (ppP p) -}
-        _ -> error $ "convert' ppP: " ++ show p
       where
         fields = map field . filter (not.isLockLabel.fst)
         field (l,p) = RecordRow (lblId l) (ppP p)
@@ -244,12 +219,12 @@ convert' gr vs = ppT
         pre Empty = [""]  -- Empty == K ""
         pre (Strs ts) = concatMap pre ts
         pre (EPatt p) = pat p
-        pre t = error $ "convert' alts pre: " ++ show t
+        pre t = error $ "pre "++show t
 
         pat (PString s) = [s]
         pat (PAlt p1 p2) = pat p1++pat p2
         pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
-        pat p = error $ "convert' alts pat: "++show p
+        pat p = error $ "pat "++show p
 
     fields = map field . filter (not.isLockLabel.fst)
     field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -262,7 +237,6 @@ convert' gr vs = ppT
                  ParamConstant (Param p (ps++[a]))
                _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
 
-concatValue :: LinValue -> LinValue -> LinValue
 concatValue v1 v2 =
   case (v1,v2) of
     (LiteralValue (StrConstant ""),_) -> v2
@@ -270,24 +244,21 @@ concatValue v1 v2 =
     _ -> ConcatValue v1 v2
 
 -- | Smart constructor for projections
-projection :: LinValue -> LabelId -> LinValue
-projection r l = fromMaybe (Projection r l) (proj r l)
+projection r l = maybe (Projection r l) id (proj r l)
 
-proj :: LinValue -> LabelId -> Maybe LinValue
 proj r l =
   case r of
-    RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
+    RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
                           [v] -> Just v
                           _ -> Nothing
     _ -> Nothing
 
 -- | Smart constructor for selections
-selection :: LinValue -> LinValue -> LinValue
 selection t v =
   -- Note: impossible cases can become possible after grammar transformation
   case t of
     TableValue tt r ->
-        case nub [rv | TableRow _ rv <- keep] of
+        case nub [rv|TableRow _ rv<-keep] of
           [rv] -> rv
           _ -> Selection (TableValue tt r') v
       where
@@ -306,16 +277,13 @@ selection t v =
         (keep,discard) = partition (mightMatchRow v) r
     _ -> Selection t v
 
-impossible :: LinValue -> LinValue
 impossible = CommentedValue "impossible"
 
-mightMatchRow :: LinValue -> TableRow rhs -> Bool
 mightMatchRow v (TableRow p _) =
   case p of
     WildPattern -> True
     _ -> mightMatch v p
 
-mightMatch :: LinValue -> LinPattern -> Bool
 mightMatch v p =
   case v of
     ConcatValue _ _ -> False
@@ -327,18 +295,16 @@ mightMatch v p =
     RecordValue rv ->
       case p of
         RecordPattern rp ->
-          and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
+          and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
         _ -> False
     _ -> True
 
-patVars :: Patt -> [Ident]
 patVars p =
   case p of
     PV x -> [x]
     PAs x p -> x:patVars p
     _ -> collectPattOp patVars p
 
-convType :: Term -> LinType
 convType = ppT
   where
     ppT t =
@@ -350,9 +316,9 @@ convType = ppT
         Sort k -> convSort k
 --      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
         FV (t:ts) -> ppT t -- !!
-        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
-        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
-        _ -> error $ "convType ppT: " ++ show t
+        QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
+        Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
+        _ -> error $ "Missing case in convType for: "++show t
 
     convFields = map convField . filter (not.isLockLabel.fst)
     convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -361,20 +327,15 @@ convType = ppT
                    "Float" -> FloatType
                    "Int" -> IntType
                    "Str" -> StrType
-                   _ -> error $ "convType convSort: " ++ show k
+                   _ -> error ("convSort "++show k)
 
-toParamType :: Term -> ParamType
 toParamType t = case convType t of
                   ParamType pt -> pt
-                  _ -> error $ "toParamType: " ++ show t
+                  _ -> error ("toParamType "++show t)
 
-toParamId :: Term -> ParamId
 toParamId t = case toParamType t of
                    ParamTypeId p -> p
 
-paramType :: G.Grammar
-             -> (ModuleName, Ident)
-             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
 paramType gr q@(_,n) =
     case lookupOrigInfo gr q of
       Ok (m,ResParam (Just (L _ ps)) _)
@@ -382,7 +343,7 @@ paramType gr q@(_,n) =
          ((S.singleton (m,n),argTypes ps),
           [ParamDef name (map (param m) ps)]
          )
-       where name = gQId m n
+       where name = (gQId m n)
       Ok (m,ResOper  _ (Just (L _ t)))
         | m==cPredef && n==cInts ->
            ((S.empty,S.empty),[]) {-
@@ -390,46 +351,36 @@ paramType gr q@(_,n) =
             [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
         | otherwise ->
            ((S.singleton (m,n),paramTypes gr t),
-            [ParamAliasDef (gQId m n) (convType t)])
+            [ParamAliasDef ((gQId m n)) (convType t)])
       _ -> ((S.empty,S.empty),[])
   where
-    param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
+    param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
     argTypes = S.unions . map argTypes1
     argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
 
-lblId :: Label -> C.LabelId
-lblId (LIdent ri) = LabelId ri
-lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
+lblId = LabelId . render -- hmm
+modId (MN m) = ModId (showIdent m)
 
-modId :: ModuleName -> C.ModId
-modId (MN m) = ModId (ident2raw m)
-
-class FromIdent i where
-  gId :: Ident -> i
+class FromIdent i where gId :: Ident -> i
 
 instance FromIdent VarId where
-  gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
+  gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
 
-instance FromIdent C.FunId where gId = C.FunId . ident2raw
-instance FromIdent CatId where gId = CatId . ident2raw
+instance FromIdent C.FunId where gId = C.FunId . showIdent
+instance FromIdent CatId where gId = CatId . showIdent
 instance FromIdent ParamId where gId = ParamId . unqual
 instance FromIdent VarValueId where gId = VarValueId . unqual
 
-class FromIdent i => QualIdent i where
-  gQId :: ModuleName -> Ident -> i
+class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
 
-instance QualIdent ParamId where gQId m n = ParamId (qual m n)
+instance QualIdent ParamId    where gQId m n = ParamId (qual m n)
 instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
 
-qual :: ModuleName -> Ident -> QualId
-qual m n = Qual (modId m) (ident2raw n)
+qual m n = Qual (modId m) (showIdent n)
+unqual n = Unqual (showIdent n)
 
-unqual :: Ident -> QualId
-unqual n = Unqual (ident2raw n)
-
-convFlags :: G.Grammar -> ModuleName -> Flags
 convFlags gr mn =
-  Flags [(rawIdentS n,convLit v) |
+  Flags [(n,convLit v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
   where
     convLit l =

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -0,0 +1,447 @@
+module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where
+
+import LPGF (LPGF (..))
+import qualified LPGF as L
+
+import PGF.CId
+import GF.Grammar.Grammar
+import qualified GF.Grammar.Canonical as C
+import GF.Compile.GrammarToCanonical (grammar2canonical)
+
+import GF.Data.Operations (ErrorMonad (..))
+import qualified GF.Data.IntMapBuilder as IntMapBuilder
+import GF.Infra.Option (Options)
+import GF.Infra.UseIO (IOE)
+import GF.Text.Pretty (pp, render)
+
+import Control.Applicative ((<|>))
+import Control.Monad (when, unless, forM, forM_)
+import qualified Control.Monad.State as CMS
+import Data.Either (lefts, rights)
+import qualified Data.IntMap as IntMap
+import Data.List (elemIndex)
+import qualified Data.List as L
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromJust, isJust)
+import System.Environment (lookupEnv)
+import System.FilePath ((</>), (<.>))
+import Text.Printf (printf)
+
+import qualified Debug.Trace
+trace x = Debug.Trace.trace ("> " ++ show x) (return ())
+
+mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
+mkCanon2lpgf opts gr am = do
+  debug <- isJust <$> lookupEnv "DEBUG"
+  when debug $ do
+    ppCanonical debugDir canon
+    dumpCanonical debugDir canon
+  (an,abs) <- mkAbstract ab
+  cncs     <- mapM (mkConcrete debug) cncs
+  let lpgf = LPGF {
+    L.absname = an,
+    L.abstract = abs,
+    L.concretes = Map.fromList cncs
+  }
+  when debug $ ppLPGF debugDir lpgf
+  return lpgf
+  where
+    canon@(C.Grammar ab cncs) = grammar2canonical opts am gr
+
+    mkAbstract :: (ErrorMonad err) => C.Abstract -> err (CId, L.Abstract)
+    mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {})
+
+    mkConcrete :: (ErrorMonad err) => Bool -> C.Concrete -> err (CId, L.Concrete)
+    mkConcrete debug (C.Concrete modId absModId flags params' lincats lindefs) = do
+      let
+        (C.Abstract _ _ _ funs) = ab
+        params = inlineParamAliases params'
+
+        -- Builds maps for lookups
+
+        paramValueMap :: Map.Map C.ParamId C.ParamDef -- constructor -> definition
+        paramValueMap = Map.fromList [ (v,d) | d@(C.ParamDef _ vs) <- params, (C.Param v _) <- vs ]
+
+        lincatMap :: Map.Map C.CatId C.LincatDef
+        lincatMap = Map.fromList [ (cid,d) | d@(C.LincatDef cid _) <- lincats ]
+
+        funMap :: Map.Map C.FunId C.FunDef
+        funMap = Map.fromList [ (fid,d) | d@(C.FunDef fid _) <- funs ]
+
+        -- | Lookup paramdef, providing dummy fallback when not found
+        -- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/100
+        lookupParamDef :: C.ParamId -> Either String C.ParamDef
+        lookupParamDef pid = case Map.lookup pid paramValueMap of
+          Just d -> Right d
+          Nothing ->
+            -- Left $ printf "Cannot find param definition: %s" (show pid)
+            Right $ C.ParamDef (C.ParamId (C.Unqual "DUMMY")) [C.Param pid []]
+
+        -- | Lookup lintype for a function
+        lookupLinType :: C.FunId -> Either String C.LinType
+        lookupLinType funId = do
+          fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap)
+          let (C.FunDef _ (C.Type _ (C.TypeApp catId _))) = fun
+          lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap)
+          let (C.LincatDef _ lt) = lincat
+          return lt
+
+        -- | Lookup lintype for a function's argument
+        lookupLinTypeArg :: C.FunId -> Int -> Either String C.LinType
+        lookupLinTypeArg funId argIx = do
+          fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap)
+          let (C.FunDef _ (C.Type args _)) = fun
+          let (C.TypeBinding _ (C.Type _ (C.TypeApp catId _))) = args !! argIx
+          lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap)
+          let (C.LincatDef _ lt) = lincat
+          return lt
+
+        -- Filter out record fields from definitions which don't appear in lincat.
+        -- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/101
+        cleanupRecordFields :: C.LinValue -> C.LinType -> C.LinValue
+        cleanupRecordFields (C.RecordValue rrvs) (C.RecordType rrs) =
+          let defnFields = Map.fromList [ (lid, lt) | (C.RecordRow lid lt) <- rrs ]
+          in C.RecordValue
+              [ C.RecordRow lid lv'
+              | C.RecordRow lid lv <- rrvs
+              , Map.member lid defnFields
+              , let Just lt = Map.lookup lid defnFields
+              , let lv' = cleanupRecordFields lv lt
+              ]
+        cleanupRecordFields lv _ = lv
+
+        lindefs' =
+          [ C.LinDef funId varIds linValue'
+          | (C.LinDef funId varIds linValue) <- lindefs
+          , let Right linType = lookupLinType funId
+          , let linValue' = cleanupRecordFields linValue linType
+          ]
+        es = map mkLin lindefs'
+        lins = Map.fromList $ rights es
+
+        -- | Main code generation function
+        mkLin :: C.LinDef -> Either String (CId, L.LinFun)
+        mkLin (C.LinDef funId varIds linValue) = do
+          -- when debug $ trace funId
+          (lf, _) <- val2lin linValue
+          return (fi2i funId, lf)
+          where
+            val2lin :: C.LinValue -> Either String (L.LinFun, Maybe C.LinType)
+            val2lin lv = case lv of
+
+              C.ConcatValue v1 v2 -> do
+                (v1',t1) <- val2lin v1
+                (v2',t2) <- val2lin v2
+                return (L.Concat v1' v2', t1 <|> t2) -- t1 else t2
+
+              C.LiteralValue ll -> case ll of
+                C.FloatConstant f -> return (L.Token $ show f, Just C.FloatType)
+                C.IntConstant i -> return (L.Token $ show i, Just C.IntType)
+                C.StrConstant s -> return (L.Token s, Just C.StrType)
+
+              C.ErrorValue err -> return (L.Error err, Nothing)
+
+              C.ParamConstant (C.Param pid lvs) -> do
+                let
+                  collectProjections :: C.LinValue -> Either String [L.LinFun]
+                  collectProjections (C.ParamConstant (C.Param pid lvs)) = do
+                    def <- lookupParamDef pid
+                    let (C.ParamDef tpid defpids) = def
+                    pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ]
+                    rest <- mapM collectProjections lvs
+                    return $ L.Ix (pidIx+1) : concat rest
+                  collectProjections lv = do
+                    (lf,_) <- val2lin lv
+                    return [lf]
+                lfs <- collectProjections lv
+                let term = L.Tuple lfs
+                def <- lookupParamDef pid
+                let (C.ParamDef tpid _) = def
+                return (term, Just $ C.ParamType (C.ParamTypeId tpid))
+
+              C.PredefValue (C.PredefId pid) -> case pid of
+                "BIND" -> return (L.Bind, Nothing)
+                "SOFT_BIND" -> return (L.Bind, Nothing)
+                "SOFT_SPACE" -> return (L.Space, Nothing)
+                "CAPIT" -> return (L.Capit, Nothing)
+                "ALL_CAPIT" -> return (L.AllCapit, Nothing)
+                _ -> Left $ printf "Unknown predef function: %s" pid
+
+              C.RecordValue rrvs -> do
+                let rrvs' = sortRecordRows rrvs
+                ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs' ]
+                return (L.Tuple (map fst ts), Just $ C.RecordType [ C.RecordRow lid lt | (C.RecordRow lid _, (_, Just lt)) <- zip rrvs' ts])
+
+              C.TableValue lt trvs -> do
+                -- group the rows by "left-most" value
+                let
+                  groupRow :: C.TableRowValue -> C.TableRowValue -> Bool
+                  groupRow (C.TableRow p1 _) (C.TableRow p2 _) = groupPattern p1 p2
+
+                  groupPattern :: C.LinPattern -> C.LinPattern -> Bool
+                  groupPattern p1 p2 = case (p1,p2) of
+                    (C.ParamPattern (C.Param pid1 _), C.ParamPattern (C.Param pid2 _)) -> pid1 == pid2 -- compare only constructors
+                    (C.RecordPattern (C.RecordRow lid1 patt1:_), C.RecordPattern (C.RecordRow lid2 patt2:_)) -> groupPattern patt1 patt2 -- lid1 == lid2 necessarily
+                    _ -> error $ printf "Mismatched patterns in grouping:\n%s\n%s" (show p1) (show p2)
+
+                  grps :: [[C.TableRowValue]]
+                  grps = L.groupBy groupRow trvs
+
+                -- remove one level of depth and recurse
+                let
+                  handleGroup :: [C.TableRowValue] -> Either String (L.LinFun, Maybe C.LinType)
+                  handleGroup [C.TableRow patt lv] =
+                    case reducePattern patt of
+                      Just patt' -> do
+                        (lf,lt) <- handleGroup [C.TableRow patt' lv]
+                        return (L.Tuple [lf],lt)
+                      Nothing    -> val2lin lv
+                  handleGroup rows = do
+                    let rows' = map reduceRow rows
+                    val2lin (C.TableValue lt rows') -- lt is wrong here, but is unused
+
+                  reducePattern :: C.LinPattern -> Maybe C.LinPattern
+                  reducePattern patt =
+                    case patt of
+                      C.ParamPattern (C.Param _ []) -> Nothing
+                      C.ParamPattern (C.Param _ patts) -> Just $ C.ParamPattern (C.Param pid' patts')
+                        where
+                          C.ParamPattern (C.Param pid1 patts1) = head patts
+                          pid' = pid1
+                          patts' = patts1 ++ tail patts
+
+                      C.RecordPattern [] -> Nothing
+                      C.RecordPattern (C.RecordRow lid patt:rrs) ->
+                        case reducePattern patt of
+                          Just patt' -> Just $ C.RecordPattern (C.RecordRow lid patt':rrs)
+                          Nothing    -> if null rrs then Nothing else Just $ C.RecordPattern rrs
+
+                      _ -> error $ printf "Unhandled pattern in reducing: %s" (show patt)
+
+                  reduceRow :: C.TableRowValue -> C.TableRowValue
+                  reduceRow (C.TableRow patt lv) =
+                    let Just patt' = reducePattern patt
+                    in  C.TableRow patt' lv
+
+                -- ts :: [(L.LinFun, Maybe C.LinType)]
+                ts <- mapM handleGroup grps
+
+                -- return
+                let typ = case ts of
+                      (_, Just tst):_ -> Just $ C.TableType lt tst
+                      _ -> Nothing
+                return (L.Tuple (map fst ts), typ)
+
+              -- TODO TuplePattern, WildPattern?
+
+              C.TupleValue lvs -> do
+                ts <- mapM val2lin lvs
+                return (L.Tuple (map fst ts), Just $ C.TupleType (map (fromJust.snd) ts))
+
+              C.VariantValue [] -> return (L.Empty, Nothing) -- TODO Just C.StrType ?
+              C.VariantValue (vr:_) -> val2lin vr -- NOTE variants not supported, just pick first
+
+              C.VarValue (C.VarValueId (C.Unqual v)) -> do
+                ix <- eitherElemIndex (C.VarId v) varIds
+                lt <- lookupLinTypeArg funId ix
+                return (L.Argument (ix+1), Just lt)
+
+              C.PreValue pts df -> do
+                pts' <- forM pts $ \(pfxs, lv) -> do
+                  (lv', _) <- val2lin lv
+                  return (pfxs, lv')
+                (df', lt) <- val2lin df
+                return (L.Pre pts' df', lt)
+
+              C.Projection v1 lblId -> do
+                (v1', mtyp) <- val2lin v1
+                -- find label index in argument type
+                let Just (C.RecordType rrs) = mtyp
+                let rrs' = [ lid | C.RecordRow lid _ <- rrs ]
+                -- lblIx <- eitherElemIndex lblId rrs'
+                let
+                  lblIx = case eitherElemIndex lblId rrs' of
+                    Right x -> x
+                    Left _ -> 0 -- corresponds to Prelude.False
+                -- lookup lintype for record row
+                let C.RecordRow _ lt = rrs !! lblIx
+                return (L.Projection v1' (L.Ix (lblIx+1)), Just lt)
+
+              C.Selection v1 v2 -> do
+                (v1', t1) <- val2lin v1
+                (v2', t2) <- val2lin v2
+                let Just (C.TableType t11 t12) = t1 -- t11 == t2
+                return (L.Projection v1' v2', Just t12)
+
+              -- C.CommentedValue cmnt lv -> val2lin lv
+              C.CommentedValue cmnt lv -> case cmnt of
+                "impossible" -> val2lin lv >>= \(_, typ) -> return (L.Empty, typ)
+                _ -> val2lin lv
+
+              v -> Left $ printf "val2lin not implemented for: %s" (show v)
+
+      unless (null $ lefts es) (raise $ unlines (lefts es))
+
+      let maybeOptimise = if debug then id else extractStrings
+      let concr = maybeOptimise $ L.Concrete {
+        L.toks = IntMap.empty,
+        L.lins = lins
+      }
+      return (mdi2i modId, concr)
+
+-- | Remove ParamAliasDefs by inlining their definitions
+inlineParamAliases :: [C.ParamDef] -> [C.ParamDef]
+inlineParamAliases defs = if null aliases then defs else map rp' pdefs
+  where
+    (aliases,pdefs) = L.partition isParamAliasDef defs
+
+    rp' :: C.ParamDef -> C.ParamDef
+    rp' (C.ParamDef pid pids) = C.ParamDef pid (map rp'' pids)
+    rp' (C.ParamAliasDef _ _) = error "inlineParamAliases called on ParamAliasDef" -- impossible
+
+    rp'' :: C.ParamValueDef -> C.ParamValueDef
+    rp'' (C.Param pid pids) = C.Param pid (map rp''' pids)
+
+    rp''' :: C.ParamId -> C.ParamId
+    rp''' pid = case L.find (\(C.ParamAliasDef p _) -> p == pid) aliases of
+      Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p
+      _ -> pid
+
+-- | Always put 's' reocord field first, then sort alphabetically.
+-- Workaround for https://github.com/GrammaticalFramework/gf-core/issues/102
+-- Based on GF.Granmar.Macros.sortRec
+sortRecordRows :: [C.RecordRowValue] -> [C.RecordRowValue]
+sortRecordRows = L.sortBy ordLabel
+  where
+    ordLabel (C.RecordRow (C.LabelId l1) _) (C.RecordRow (C.LabelId l2) _) =
+      case (l1,l2) of
+        ("s",_) -> LT
+        (_,"s") -> GT
+        (s1,s2) -> compare s1 s2
+
+-- sortRecord :: C.LinValue -> C.LinValue
+-- sortRecord (C.RecordValue rrvs) = C.RecordValue (sortRecordRows rrvs)
+-- sortRecord lv = lv
+
+isParamAliasDef :: C.ParamDef -> Bool
+isParamAliasDef (C.ParamAliasDef _ _) = True
+isParamAliasDef _ = False
+
+isParamType :: C.LinType -> Bool
+isParamType (C.ParamType _) = True
+isParamType _ = False
+
+isRecordType :: C.LinType -> Bool
+isRecordType (C.RecordType _) = True
+isRecordType _ = False
+
+-- | Find all token strings, put them in a map and replace with token indexes
+extractStrings :: L.Concrete -> L.Concrete
+extractStrings concr = L.Concrete { L.toks = toks', L.lins = lins' }
+  where
+    imb = IntMapBuilder.fromIntMap (L.toks concr)
+    (lins',imb') = CMS.runState (go0 (L.lins concr)) imb
+    toks' = IntMapBuilder.toIntMap imb'
+
+    go0 :: Map.Map CId L.LinFun -> CMS.State (IntMapBuilder.IMB String) (Map.Map CId L.LinFun)
+    go0 mp = do
+      xs <- mapM (\(cid,lin) -> go lin >>= \lin' -> return (cid,lin')) (Map.toList mp)
+      return $ Map.fromList xs
+
+    go :: L.LinFun -> CMS.State (IntMapBuilder.IMB String) L.LinFun
+    go lf = case lf of
+      L.Token str -> do
+        imb <- CMS.get
+        let (ix,imb') = IntMapBuilder.insert' str imb
+        CMS.put imb'
+        return $ L.TokenIx ix
+
+      L.Pre pts df -> do
+        -- pts' <- mapM (\(pfxs,lv) -> go lv >>= \lv' -> return (pfxs,lv')) pts
+        pts' <- forM pts $ \(pfxs,lv) -> do
+          imb <- CMS.get
+          let str = show pfxs
+          let (ix,imb') = IntMapBuilder.insert' str imb
+          CMS.put imb'
+          lv' <- go lv
+          return (ix,lv')
+        df' <- go df
+        return $ L.PreIx pts' df'
+      L.Concat s t -> do
+        s' <- go s
+        t' <- go t
+        return $ L.Concat s' t'
+      L.Tuple ts -> do
+        ts' <- mapM go ts
+        return $ L.Tuple ts'
+      L.Projection t u -> do
+        t' <- go t
+        u' <- go u
+        return $ L.Projection t' u'
+      t -> return t
+
+-- | Convert Maybe to Either value with error
+m2e :: String -> Maybe a -> Either String a
+m2e err = maybe (Left err) Right
+
+-- | Wrap elemIndex into Either value
+eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
+eitherElemIndex x xs = m2e (printf "Cannot find: %s in %s" (show x) (show xs)) (elemIndex x xs)
+
+mdi2s :: C.ModId -> String
+mdi2s (C.ModId i) = i
+
+mdi2i :: C.ModId -> CId
+mdi2i (C.ModId i) = mkCId i
+
+fi2i :: C.FunId -> CId
+fi2i (C.FunId i) = mkCId i
+
+-- Debugging
+
+debugDir :: FilePath
+debugDir = "DEBUG"
+
+-- | Pretty-print canonical grammars to file
+ppCanonical :: FilePath -> C.Grammar -> IO ()
+ppCanonical path (C.Grammar ab cncs) = do
+  let (C.Abstract modId flags cats funs) = ab
+  writeFile (path </> mdi2s modId <.> "canonical.gf") (render $ pp ab)
+  forM_ cncs $ \cnc@(C.Concrete modId absModId flags params lincats lindefs) ->
+    writeFile' (path </> mdi2s modId <.> "canonical.gf") (render $ pp cnc)
+
+-- | Dump canonical grammars to file
+dumpCanonical :: FilePath -> C.Grammar -> IO ()
+dumpCanonical path (C.Grammar ab cncs) = do
+  let (C.Abstract modId flags cats funs) = ab
+  let body = unlines $ map show cats ++ [""] ++ map show funs
+  writeFile' (path </> mdi2s modId <.> "canonical.dump") body
+
+  forM_ cncs $ \(C.Concrete modId absModId flags params lincats lindefs) -> do
+    let body = unlines $ concat [
+          map show params,
+          [""],
+          map show lincats,
+          [""],
+          map show lindefs
+          ]
+    writeFile' (path </> mdi2s modId <.> "canonical.dump") body
+
+-- | Pretty-print LPGF to file
+ppLPGF :: FilePath -> LPGF -> IO ()
+ppLPGF path lpgf =
+  forM_ (Map.toList $ L.concretes lpgf) $ \(cid,concr) ->
+    writeFile' (path </> showCId cid <.> "lpgf.txt") (L.render $ L.pp concr)
+
+-- | Dump LPGF to file
+dumpLPGF :: FilePath -> LPGF -> IO ()
+dumpLPGF path lpgf =
+  forM_ (Map.toList $ L.concretes lpgf) $ \(cid,concr) -> do
+    let body = unlines $ map show (Map.toList $ L.lins concr)
+    writeFile' (path </> showCId cid <.> "lpgf.dump") body
+
+-- | Write a file and report it to console
+writeFile' :: FilePath -> String -> IO ()
+writeFile' p b = do
+  writeFile p b
+  putStrLn $ "Wrote " ++ p

src/compiler/GF/Compile/Optimize.hs

@@ -6,7 +6,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/16 13:56:13 $
+-- > CVS $Date: 2005/09/16 13:56:13 $ 
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.18 $
 --
@@ -21,7 +21,7 @@ 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.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
 import GF.Data.Operations
 import GF.Infra.Option
 
@@ -90,7 +90,7 @@ evalInfo opts resenv sgr m c info = do
     let ppr' = fmap (evalPrintname resenv c) ppr
     return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
 {-
-  ResOper pty pde
+  ResOper pty pde 
     | not new && OptExpand `Set.member` optim -> do
          pde' <- case pde of
                    Just (L loc de) -> do de <- computeConcrete gr de
@@ -171,13 +171,13 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
      _ -> Bad (render ("linearization type field cannot be" <+> typ))
 
 mkLinReference :: SourceGrammar -> Type -> Err Term
-mkLinReference gr typ =
- liftM (Abs Explicit varStr) $
+mkLinReference gr typ = 
+ liftM (Abs Explicit varStr) $ 
    case mkDefField typ (Vr varStr) of
      Bad "no string" -> return Empty
      x               -> x
  where
-   mkDefField ty trm =
+   mkDefField ty trm = 
      case ty of
        Table pty ty -> do ps <- allParamValues gr pty
                           case ps of
@@ -203,7 +203,7 @@ factor param c i t =
     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
+    factors ty pvs0  
                  | not param = V ty (map snd pvs0)
     factors ty []            = V ty []
     factors ty pvs0@[(p,v)]  = V ty [v]
@@ -224,7 +224,7 @@ factor param c i t =
 replace :: Term -> Term -> Term -> Term
 replace old new trm =
   case trm of
-    -- these are the important cases, since they can correspond to patterns
+    -- these are the important cases, since they can correspond to patterns  
     QC _     | trm == old -> new
     App _ _  | trm == old -> new
     R _      | trm == old -> new

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/17 12:39:07 $
+-- > CVS $Date: 2005/06/17 12:39:07 $ 
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.8 $
 --
@@ -22,7 +22,7 @@ import PGF.Internal
 import GF.Data.Operations
 import GF.Infra.Option
 
-import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
+import Data.List --(isPrefixOf, find, intersperse)
 import qualified Data.Map as Map
 
 type Prefix = String -> String
@@ -34,12 +34,11 @@ grammar2haskell :: Options
                 -> PGF
                 -> String
 grammar2haskell opts name gr = foldr (++++) [] $
-  pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
+  pragmas ++ haskPreamble gadt name derivingClause extraImports ++
   [types, gfinstances gId lexical gr'] ++ compos
     where gr' = hSkeleton gr
           gadt = haskellOption opts HaskellGADT
           dataExt = haskellOption opts HaskellData
-          pgf2 = haskellOption opts HaskellPGF2
           lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
           gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
               | otherwise = ("G"++) . rmForbiddenChars
@@ -51,23 +50,21 @@ grammar2haskell opts name gr = foldr (++++) [] $
           derivingClause
                  | dataExt = "deriving (Show,Data)"
                  | otherwise = "deriving Show"
-          extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
+          extraImports | gadt = ["import Control.Monad.Identity",
+                                 "import Data.Monoid"]
                        | dataExt = ["import Data.Data"]
                        | otherwise = []
-          pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
-                     | otherwise = ["import PGF hiding (Tree)"]
           types | gadt = datatypesGADT gId lexical gr'
                 | otherwise = datatypes gId derivingClause lexical gr'
           compos | gadt = prCompos gId lexical gr' ++ composClass
                  | otherwise = []
 
-haskPreamble :: Bool -> String -> String -> [String] -> [String]
-haskPreamble gadt name derivingClause imports =
+haskPreamble gadt name derivingClause extraImports =
  [
   "module " ++ name ++ " where",
   ""
- ] ++ imports ++ [
-  "",
+ ] ++ extraImports ++ [
+  "import PGF hiding (Tree)",
   "----------------------------------------------------",
   "-- automatic translation from GF to Haskell",
   "----------------------------------------------------",
@@ -88,11 +85,10 @@ haskPreamble gadt name derivingClause imports =
   ""
  ]
 
-predefInst :: Bool -> String -> String -> String -> String -> String -> String
 predefInst gadt derivingClause gtyp typ destr consr =
   (if gadt
     then []
-    else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
+    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
     )
   ++
   "instance Gf" +++ gtyp +++ "where" ++++
@@ -107,10 +103,10 @@ type OIdent = String
 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 
 datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
+datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
 
 gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
+gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
 
 
 hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
@@ -135,17 +131,16 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
 lexicalConstructor :: OIdent -> String
 lexicalConstructor cat = "Lex" ++ cat
 
-predefTypeSkel :: HSkeleton
 predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
 
 -- GADT version of data types
 datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypesGADT gId lexical (_,skel) = unlines $
+datatypesGADT gId lexical (_,skel) = unlines $ 
     concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
-    [
-      "",
+    [ 
+      "", 
       "data Tree :: * -> * where"
-    ] ++
+    ] ++ 
     concatMap (map ("  "++) . hDatatypeGADT gId lexical) skel ++
     [
       "  GString :: String -> Tree GString_",
@@ -169,23 +164,23 @@ hCatTypeGADT gId (cat,rules)
        "data"+++gId cat++"_"]
 
 hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
-hDatatypeGADT gId lexical (cat, rules)
+hDatatypeGADT gId lexical (cat, rules) 
     | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
     | otherwise =
-        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t 
           | (f,args) <- nonLexicalRules (lexical cat) rules ]
         ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
   where t = "Tree" +++ gId cat ++ "_"
 
 hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
 hEqGADT gId lexical (cat, rules)
-  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
+  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] 
   | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
           ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
 
  where
    patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
-   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
+   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | 
      (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
    listr c = (c,["foo"]) -- foo just for length = 1
    listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -194,26 +189,25 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
 prCompos gId lexical (_,catrules) =
     ["instance Compos Tree where",
      "  compos r a f t = case t of"]
-    ++
+    ++ 
     ["    " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
-                                         (f,xs) <- rs, not (null xs)]
-    ++
+                                         (f,xs) <- rs, not (null xs)] 
+    ++ 
     ["    " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
-    ++
+    ++ 
     ["    _ -> r t"]
   where
-    prComposCons f xs = let vs = mkVars (length xs) in
+    prComposCons f xs = let vs = mkVars (length xs) in 
                         f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
     rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
-    prRec f (v,c)
+    prRec f (v,c) 
       | isList f  = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
       | otherwise = "`a`" +++ "f" +++ v
-    isList f = gId "List" `isPrefixOf` f
+    isList f = (gId "List") `isPrefixOf` f
 
 gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
 gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
 
-hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
 ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
 hInstance gId _ m (cat,[]) = unlines [
   "instance Show" +++ gId cat,
@@ -222,15 +216,15 @@ hInstance gId _ m (cat,[]) = unlines [
   "  gf _ = undefined",
   "  fg _ = undefined"
   ]
-hInstance gId lexical m (cat,rules)
+hInstance gId lexical m (cat,rules) 
  | isListCat (cat,rules) =
   "instance Gf" +++ gId cat +++ "where" ++++
-     "  gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
+     "  gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
            +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
-     "  gf (" ++ gId cat +++ "(x:xs)) = "
-           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
+     "  gf (" ++ gId cat +++ "(x:xs)) = " 
+           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] 
 -- no show for GADTs
---     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
+--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" 
  | otherwise =
   "instance Gf" +++ gId cat +++ "where\n" ++
   unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -239,22 +233,19 @@ hInstance gId lexical m (cat,rules)
    ec = elemCat cat
    baseVars = mkVars (baseSize (cat,rules))
    mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
-     (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
      "=" +++ mkRHS f xx'
-   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
-       "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ 
+		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
 
-mkVars :: Int -> [String]
 mkVars = mkSVars "x"
-
-mkSVars :: String -> Int -> [String]
 mkSVars s n = [s ++ show i | i <- [1..n]]
 
 ----fInstance m ("Cn",_) = "" ---
 fInstance _ _ m (cat,[]) = ""
 fInstance gId lexical m (cat,rules) =
   "  fg t =" ++++
-  (if isList
+  (if isList 
     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] ++++
@@ -266,28 +257,27 @@ fInstance gId lexical m (cat,rules) =
      "      Just (i," ++
      "[" ++ prTList "," xx' ++ "])" +++
      "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
-       where
-         xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
-         mkRHS f vars
-           | isList =
-               if "Base" `isPrefixOf` f
-                             then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
-                 else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
-           | otherwise =
-               gId f +++
-               prTList " " [prParenth ("fg" +++ x) | x <- vars]
+       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+	     mkRHS f vars 
+		 | isList =
+		     if "Base" `isPrefixOf` f 
+                       then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+		       else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
+		 | otherwise = 
+		     gId f +++  
+		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
 
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr =
-  (showCId (absname gr),
-   let fs =
-         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- 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)]
+   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
-   cts = Map.keys (cats (abstract gr))
+   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
@@ -301,10 +291,9 @@ updateSkeleton cat skel rule =
 -}
 isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
 isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
-        && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
-    where
-      c = elemCat cat
-      fs = map fst rules
+		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where c = elemCat cat
+	  fs = map fst rules
 
 -- | Gets the element category of a list category.
 elemCat :: OIdent -> OIdent
@@ -321,7 +310,7 @@ baseSize (_,rules) = length bs
     where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
 
 composClass :: [String]
-composClass =
+composClass = 
     [
      "",
      "class Compos t where",
@@ -348,3 +337,4 @@ composClass =
      "",
      "newtype C b a = C { unC :: b }"
     ]
+

src/compiler/GF/Compile/Rename.hs

@@ -39,7 +39,6 @@ import GF.Data.Operations
 
 import Control.Monad
 import Data.List (nub,(\\))
-import qualified Data.List as L
 import qualified Data.Map as Map
 import Data.Maybe(mapMaybe)
 import GF.Text.Pretty
@@ -106,26 +105,7 @@ renameIdentTerm' env@(act,imps) t0 =
                               ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
                                                         "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
                                                         "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                                             return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
-       where
-        -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
-        -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
-        notFromCommonModule :: Term -> Bool
-        notFromCommonModule term =
-          let t = render $ ppTerm Qualified 0 term :: String
-           in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
-                        ["CommonX", "ConstructX", "ExtendFunctor"
-                        ,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
-
-        -- If one of the terms comes from the common modules,
-        -- we choose the other one, because that's defined in the grammar.
-        bestTerm :: [Term] -> Term
-        bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
-        bestTerm ts@(t:_) =
-          let notCommon = [t | t <- ts, notFromCommonModule t]
-           in case notCommon of
-                []    -> t -- All terms are from common modules, return first of original list
-                (u:_) -> u -- ≥1 terms are not from common modules, return first of those
+                                             return t
 
 info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
 info2status mq c i = case i of

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

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

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

@@ -10,7 +10,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType)
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
-import GF.Compile.Compute.Concrete
+import GF.Compile.Compute.ConcreteNew
 import GF.Compile.Compute.Predef(predef,predefName)
 import GF.Infra.CheckM
 import GF.Data.Operations
@@ -133,7 +133,7 @@ tcRho ge scope t@(RecType rs) (Just ty) = do
                          [] -> unifyVar ge scope i env vs vtypePType
                          _  -> return ()
     ty              -> do ty <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) ty
-                          tcError ("The record type" <+> ppTerm Unqualified 0 t $$
+                          tcError ("The record type" <+> ppTerm Unqualified 0 t $$ 
                                    "cannot be of type" <+> ppTerm Unqualified 0 ty)
   (rs,mb_ty) <- tcRecTypeFields ge scope rs (Just ty')
   return (f (RecType rs),ty)
@@ -187,7 +187,7 @@ tcRho ge scope (R rs) (Just ty) = do
   case ty' of
     (VRecType ltys) -> do lttys <- checkRecFields ge scope rs ltys
                           rs <- mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
-                          return ((f . R)  rs,
+                          return ((f . R)  rs, 
                                   VRecType [(l, ty) | (l,t,ty) <- lttys]
                                  )
     ty              -> do lttys <- inferRecFields ge scope rs
@@ -277,11 +277,11 @@ tcApp ge scope (App fun arg) =                                  -- APP2
         varg <- liftErr (eval ge (scopeEnv scope) arg)
         return (App fun arg, res_ty varg)
 tcApp ge scope (Q id) =                                          -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
+  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> 
      do ty <- liftErr (eval ge [] ty)
         return (t,ty)
 tcApp ge scope (QC id) =                                         -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
+  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> 
      do ty <- liftErr (eval ge [] ty)
         return (t,ty)
 tcApp ge scope t =
@@ -350,7 +350,7 @@ tcPatt ge scope (PM q) ty0 = do
     Bad err -> tcError (pp err)
 tcPatt ge scope p ty = unimplemented ("tcPatt "++show p)
 
-inferRecFields ge scope rs =
+inferRecFields ge scope rs = 
   mapM (\(l,r) -> tcRecField ge scope l r Nothing) rs
 
 checkRecFields ge scope []          ltys
@@ -368,7 +368,7 @@ checkRecFields ge scope ((l,t):lts) ltys =
   where
     takeIt l1 []  = (Nothing, [])
     takeIt l1 (lty@(l2,ty):ltys)
-      | l1 == l2  = (Just ty,ltys)
+      | l1 == l2  = (Just ty,ltys) 
       | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
                     in (mb_ty,lty:ltys')
 
@@ -390,7 +390,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
                | s == cPType -> return mb_ty
              VMeta _ _ _     -> return mb_ty
              _               -> do sort <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) sort
-                                   tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
+                                   tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$ 
                                             "cannot be of type" <+> ppTerm Unqualified 0 sort)
   (rs,mb_ty) <- tcRecTypeFields ge scope rs mb_ty
   return ((l,ty):rs,mb_ty)
@@ -444,11 +444,11 @@ subsCheckRho ge scope t (VApp p1 _) (VApp p2 _)                         -- Rule
   | predefName p1 == cInts && predefName p2 == cInt = return t
 subsCheckRho ge scope t (VApp p1 [VInt i]) (VApp p2 [VInt j])           -- Rule INT2
   | predefName p1 == cInts && predefName p2 == cInts =
-      if i <= j
+      if i <= j 
         then return t
         else tcError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
 subsCheckRho ge scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
-  let mkAccess scope t =
+  let mkAccess scope t = 
         case t of
           ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
                            (scope,mkProj2,mkWrap2) <- mkAccess scope t2
@@ -557,7 +557,7 @@ unify ge scope v (VMeta i env vs) = unifyVar ge scope i env vs v
 unify ge scope v1 v2 = do
   t1 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v1
   t2 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v2
-  tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$
+  tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$ 
                                       ppTerm Unqualified 0 t2))
 
 -- | Invariant: tv1 is a flexible type variable
@@ -609,7 +609,7 @@ quantify ge scope t tvs ty0 = do
   ty <- tc_value2term (geLoc ge) (scopeVars scope) ty0
   let used_bndrs = nub (bndrs ty)  -- Avoid quantified type variables in use
       new_bndrs  = take (length tvs) (allBinders \\ used_bndrs)
-  mapM_ bind (tvs `zip` new_bndrs)   -- 'bind' is just a cunning way
+  mapM_ bind (tvs `zip` new_bndrs)   -- 'bind' is just a cunning way 
   ty <- zonkTerm ty                  -- of doing the substitution
   vty <- liftErr (eval ge [] (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs))
   return (foldr (Abs Implicit) t new_bndrs,vty)
@@ -619,7 +619,7 @@ quantify ge scope t tvs ty0 = do
     bndrs (Prod _ x t1 t2) = [x] ++ bndrs t1  ++ bndrs t2
     bndrs _                = []
 
-allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,...
+allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,... 
 allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
              [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
 
@@ -688,12 +688,12 @@ runTcM f = case unTcM f IntMap.empty [] of
              TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg
 
 newMeta :: Scope -> Sigma -> TcM MetaId
-newMeta scope ty = TcM (\ms msgs ->
+newMeta scope ty = TcM (\ms msgs -> 
   let i = IntMap.size ms
   in TcOk i (IntMap.insert i (Unbound scope ty) ms) msgs)
 
 getMeta :: MetaId -> TcM MetaValue
-getMeta i = TcM (\ms msgs ->
+getMeta i = TcM (\ms msgs -> 
   case IntMap.lookup i ms of
     Just mv -> TcOk mv ms msgs
     Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs))
@@ -702,7 +702,7 @@ setMeta :: MetaId -> MetaValue -> TcM ()
 setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)
 
 newVar :: Scope -> Ident
-newVar scope = head [x | i <- [1..],
+newVar scope = head [x | i <- [1..], 
                          let x = identS ('v':show i),
                          isFree scope x]
   where
@@ -721,7 +721,7 @@ getMetaVars loc sc_tys = do
   return (foldr go [] tys)
   where
     -- Get the MetaIds from a term; no duplicates in result
-    go (Vr tv)    acc = acc
+    go (Vr tv)    acc = acc 
     go (App x y)  acc = go x (go y acc)
     go (Meta i)   acc
 	  | i `elem` acc  = acc
@@ -741,7 +741,7 @@ getFreeVars loc sc_tys = do
   tys <- mapM (\(scope,ty) -> zonkTerm =<< tc_value2term loc (scopeVars scope) ty) sc_tys
   return (foldr (go []) [] tys)
   where
-    go bound (Vr tv)            acc
+    go bound (Vr tv)            acc 
 	  | tv `elem` bound             = acc
 	  | tv `elem` acc               = acc
 	  | otherwise                   = tv : acc
@@ -771,7 +771,7 @@ tc_value2term loc xs v =
 
 
 
-data TcA x a
+data TcA x a 
   = TcSingle   (MetaStore -> [Message] -> TcResult a)
   | TcMany [x] (MetaStore -> [Message] -> [(a,MetaStore,[Message])])
 

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

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

src/compiler/GF/Compiler.hs

@@ -1,9 +1,11 @@
-module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writePGF, writeLPGF, writeOutputs) where
 
 import PGF
 import PGF.Internal(concretes,optimizePGF,unionPGF)
 import PGF.Internal(putSplitAbs,encodeFile,runPut)
-import GF.Compile as S(batchCompile,link,srcAbsName)
+import LPGF(LPGF)
+import qualified LPGF
+import GF.Compile as S(batchCompile,link,linkl,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
 import GF.Compile.ConcreteToHaskell(concretes2haskell)
@@ -11,7 +13,8 @@ import GF.Compile.GrammarToCanonical--(concretes2canonical)
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
-import GF.Grammar.CFG
+import GF.Grammar.CFG hiding (Grammar)
+import GF.Grammar.Grammar (Grammar, ModuleName)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
@@ -23,10 +26,11 @@ import GF.Text.Pretty(render,render80)
 import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Time(UTCTime)
 import qualified Data.ByteString.Lazy as BSL
 import GF.Grammar.CanonicalJSON (encodeJSON)
 import System.FilePath
-import Control.Monad(when,unless,forM_)
+import Control.Monad(when,unless,forM,void)
 
 -- | Compile the given GF grammar files. The result is a number of @.gfo@ files
 -- and, depending on the options, a @.pgf@ file. (@gf -batch@, @gf -make@)
@@ -47,7 +51,7 @@ mainGFC opts fs = do
    extensionIs ext = (== ext) .  takeExtension
 
 compileSourceFiles :: Options -> [FilePath] -> IOE ()
-compileSourceFiles opts fs = 
+compileSourceFiles opts fs =
     do output <- batchCompile opts fs
        exportCanonical output
        unless (flag optStopAfterPhase opts == Compile) $
@@ -93,6 +97,10 @@ compileSourceFiles opts fs =
 -- If a @.pgf@ file by the same name already exists and it is newer than the
 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
 -- recreated. Calls 'writePGF' and 'writeOutputs'.
+linkGrammars :: Options -> (UTCTime,[(ModuleName, Grammar)]) -> IOE ()
+linkGrammars opts (_,cnc_grs) | FmtLPGF `elem` flag optOutputFormats opts = do
+  lpgf <- linkl opts (head cnc_grs)
+  void $ writeLPGF opts lpgf
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -145,7 +153,7 @@ unionPGFFiles opts fs =
              pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
          if pgfFile `elem` fs
            then putStrLnE $ "Refusing to overwrite " ++ pgfFile
-           else writePGF opts pgf
+           else void $ writePGF opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -155,33 +163,46 @@ unionPGFFiles opts fs =
 -- Calls 'exportPGF'.
 writeOutputs :: Options -> PGF -> IOE ()
 writeOutputs opts pgf = do
-  sequence_ [writeOutput opts name str 
+  sequence_ [writeOutput opts name str
                  | fmt <- flag optOutputFormats opts,
                    (name,str) <- exportPGF opts fmt pgf]
 
 -- | 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.
-writePGF :: Options -> PGF -> IOE ()
+writePGF :: Options -> PGF -> IOE [FilePath]
 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 $ encodeFile outfile pgf
+          return [outfile]
 
     writeSplitPGF =
       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
          writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
                                 --encodeFile_ outfile (putSplitAbs pgf)
-         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
+         outfiles <- forM (Map.toList (concretes pgf)) $ \cnc -> do
            let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
            writing opts outfile $ encodeFile outfile cnc
+           return outfile
 
+         return (outfile:outfiles)
 
-writeOutput :: Options -> FilePath-> String -> IOE ()
-writeOutput opts file str = writing opts path $ writeUTF8File path str
-  where path = outputPath opts file
+writeLPGF :: Options -> LPGF -> IOE FilePath
+writeLPGF opts lpgf = do
+  let
+    grammarName = fromMaybe (showCId (LPGF.abstractName lpgf)) (flag optName opts)
+    outfile = outputPath opts (grammarName <.> "lpgf")
+  writing opts outfile $ liftIO $ LPGF.encodeFile outfile lpgf
+  return outfile
+
+writeOutput :: Options -> FilePath-> String -> IOE FilePath
+writeOutput opts file str = do
+  let outfile = outputPath opts file
+  writing opts outfile $ writeUTF8File outfile str
+  return outfile
 
 -- * Useful helper functions
 

src/compiler/GF/Data/IntMapBuilder.hs

@@ -0,0 +1,57 @@
+-- | In order to build an IntMap in one pass, we need a map data structure with
+-- fast lookup in both keys and values.
+-- This is achieved by keeping a separate reversed map of values to keys during building.
+module GF.Data.IntMapBuilder where
+
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import Data.Hashable (Hashable)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Tuple (swap)
+import Prelude hiding (lookup)
+
+data IMB a = IMB {
+  intMap :: IntMap a,
+  valMap :: HashMap a Int
+}
+
+-- | An empty IMB
+empty :: (Eq a, Hashable a) => IMB a
+empty = IMB {
+  intMap = IntMap.empty,
+  valMap = HashMap.empty
+}
+
+-- | Lookup a value
+lookup :: (Eq a, Hashable a) => a -> IMB a -> Maybe Int
+lookup a IMB { valMap = vm } = HashMap.lookup a vm
+
+-- | Insert without any lookup
+insert :: (Eq a, Hashable a) => a -> IMB a -> (Int, IMB a)
+insert a IMB { intMap = im, valMap = vm } =
+  let
+    ix = IntMap.size im
+    im' = IntMap.insert ix a im
+    vm' = HashMap.insert a ix vm
+    imb' = IMB { intMap = im', valMap = vm' }
+  in
+    (ix, imb')
+
+-- | Insert only when lookup fails
+insert' :: (Eq a, Hashable a) => a -> IMB a -> (Int, IMB a)
+insert' a imb =
+  case lookup a imb of
+    Just ix -> (ix, imb)
+    Nothing -> insert a imb
+
+-- | Build IMB from existing IntMap
+fromIntMap :: (Eq a, Hashable a) => IntMap a -> IMB a
+fromIntMap im = IMB {
+  intMap = im,
+  valMap = HashMap.fromList (map swap (IntMap.toList im))
+}
+
+-- | Get IntMap from IMB
+toIntMap :: (Eq a, Hashable a) => IMB a -> IntMap a
+toIntMap = intMap

src/compiler/GF/Grammar/Canonical.hs

@@ -11,7 +11,6 @@
 module GF.Grammar.Canonical where
 import Prelude hiding ((<>))
 import GF.Text.Pretty
-import GF.Infra.Ident (RawIdent)
 
 -- | A Complete grammar
 data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -31,7 +30,7 @@ data TypeApp  = TypeApp CatId [Type]        deriving Show
 data TypeBinding = TypeBinding VarId Type   deriving Show
 
 --------------------------------------------------------------------------------
--- ** Concreate syntax
+-- ** Concrete syntax
 
 -- | Concrete Syntax
 data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
@@ -45,12 +44,12 @@ data LincatDef = LincatDef CatId LinType  deriving Show
 data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
 
 -- | Linearization type, RHS of @lincat@
-data LinType = FloatType 
-             | IntType 
+data LinType = FloatType
+             | IntType
              | ParamType ParamType
              | RecordType [RecordRowType]
-             | StrType 
-             | TableType LinType LinType 
+             | StrType
+             | TableType LinType LinType
              | TupleType [LinType]
               deriving (Eq,Ord,Show)
 
@@ -60,7 +59,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 data LinValue = ConcatValue LinValue LinValue
               | LiteralValue LinLiteral
               | ErrorValue String
-              | ParamConstant ParamValue 
+              | ParamConstant ParamValue
               | PredefValue PredefId
               | RecordValue [RecordRowValue]
               | TableValue LinType [TableRowValue]
@@ -74,9 +73,9 @@ data LinValue = ConcatValue LinValue LinValue
               | CommentedValue String LinValue
               deriving (Eq,Ord,Show)
 
-data LinLiteral = FloatConstant Float 
-                | IntConstant Int 
-                | StrConstant String 
+data LinLiteral = FloatConstant Float
+                | IntConstant Int
+                | StrConstant String
                 deriving (Eq,Ord,Show)
 
 data LinPattern = ParamPattern ParamPattern
@@ -103,11 +102,11 @@ data TableRow  rhs = TableRow  LinPattern rhs
 
 -- *** Identifiers in Concrete Syntax
 
-newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
-newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
-data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
+newtype PredefId   = PredefId Id        deriving (Eq,Ord,Show)
+newtype LabelId    = LabelId Id         deriving (Eq,Ord,Show)
+newtype VarValueId = VarValueId QualId  deriving (Eq,Ord,Show)
 
--- | Name of param type or param value 
+-- | Name of param type or param value
 newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
@@ -116,9 +115,9 @@ newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 newtype ModId = ModId Id  deriving (Eq,Ord,Show)
 
 newtype CatId = CatId Id  deriving (Eq,Ord,Show)
-newtype FunId = FunId Id  deriving (Eq,Show)
+newtype FunId = FunId Id  deriving (Eq,Ord,Show)
 
-data VarId = Anonymous | VarId Id  deriving Show
+data VarId = Anonymous | VarId Id  deriving (Eq,Show)
 
 newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
 type FlagName = Id
@@ -127,7 +126,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
 
 -- *** Identifiers
 
-type Id = RawIdent
+type Id = String
 data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
@@ -250,7 +249,7 @@ instance PPA LinLiteral where
             FloatConstant f -> pp f
             IntConstant n -> pp n
             StrConstant s -> doubleQuotes s -- hmm
-  
+
 instance RhsSeparator LinValue where rhsSep _ = pp "="
 
 instance Pretty LinPattern where
@@ -265,7 +264,8 @@ instance PPA LinPattern where
       ParamPattern pv -> ppA pv
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"                
+      WildPattern     -> pp "_"
+      _ -> parens p
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="
 

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -7,7 +7,6 @@ import Control.Applicative ((<|>))
 import Data.Ratio (denominator, numerator)
 import GF.Grammar.Canonical
 import Control.Monad (guard)
-import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
 
 
 encodeJSON :: FilePath -> Grammar -> IO ()
@@ -30,7 +29,7 @@ instance JSON Grammar where
 -- ** Abstract Syntax
 
 instance JSON Abstract where
-  showJSON (Abstract absid flags cats funs)
+  showJSON (Abstract absid flags cats funs) 
     = makeObj [("abs", showJSON absid),
                ("flags", showJSON flags),
                ("cats", showJSON cats),
@@ -82,7 +81,7 @@ instance JSON TypeBinding where
 -- ** Concrete syntax
 
 instance JSON Concrete where
-  showJSON (Concrete cncid absid flags params lincats lins)
+  showJSON (Concrete cncid absid flags params lincats lins) 
     = makeObj [("cnc", showJSON cncid),
                ("abs", showJSON absid),
                ("flags", showJSON flags),
@@ -205,12 +204,12 @@ instance JSON a => JSON (RecordRow a) where
   -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
   showJSON  row  = showJSONs [row]
   showJSONs rows = makeObj (map toRow rows)
-    where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
+    where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
 
   readJSON  obj = head <$> readJSONs obj
   readJSONs obj = mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (RecordRow (LabelId (rawIdentS lbl)) value)
+                                      return (RecordRow (LabelId lbl) value)
 
 instance JSON rhs => JSON (TableRow rhs) where
   showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
@@ -220,19 +219,19 @@ instance JSON rhs => JSON (TableRow rhs) where
 
 -- *** Identifiers in Concrete Syntax
 
-instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON
-instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON
-instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON
-instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON
-instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
+instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON 
+instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON 
+instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON 
+instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON 
+instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON 
 
 
 --------------------------------------------------------------------------------
 -- ** Used in both Abstract and Concrete Syntax
 
-instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
-instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
-instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
+instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON 
+instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON 
+instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON 
 
 instance JSON VarId where
   -- the anonymous variable is the underscore:
@@ -243,24 +242,20 @@ instance JSON VarId where
     <|>        VarId <$> readJSON o
 
 instance JSON QualId where
-  showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
+  showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
   showJSON (Unqual n) = showJSON n
 
   readJSON o = do qualid <- readJSON o
                   let (mod, id) = span (/= '.') qualid
-                  return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
-
-instance JSON RawIdent where
-  showJSON i = showJSON $ showRawIdent i
-  readJSON o = rawIdentS <$> readJSON o
+                  return $ if null mod then Unqual id else Qual (ModId mod) id
 
 instance JSON Flags where
   -- flags are encoded directly as JSON records (i.e., objects):
-  showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
+  showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
 
   readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (rawIdentS lbl, value)
+                                      return (lbl, value)
 
 instance JSON FlagValue where
   -- flag values are encoded as basic JSON types:

src/compiler/GF/Grammar/Macros.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/11 16:38:00 $
+-- > CVS $Date: 2005/11/11 16:38:00 $ 
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.24 $
 --
@@ -51,14 +51,14 @@ typeForm t =
     _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
 
 typeFormCnc :: Type -> (Context, Type)
-typeFormCnc t =
+typeFormCnc t = 
   case t of
     Prod b x a t -> let (x', v) = typeFormCnc t
                     in ((b,x,a):x',v)
     _            -> ([],t)
 
 valCat :: Type -> Cat
-valCat typ =
+valCat typ = 
   let (_,cat,_) = typeForm typ
   in cat
 
@@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do  -- pessimistic choice
 contextOfType :: Monad m => Type -> m Context
 contextOfType typ = case typ of
   Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
-  _            -> return []
+  _            -> return [] 
 
 termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
 termForm t = case t of
@@ -108,8 +108,8 @@ termForm t = case t of
         return ((b,x):x', fun, args)
    App c a ->
      do (_,fun, args) <- termForm c
-        return ([],fun,args ++ [a])
-   _       ->
+        return ([],fun,args ++ [a]) 
+   _       -> 
      return ([],t,[])
 
 termFormCnc :: Term -> ([(BindType,Ident)], Term)
@@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term
 mkTable tt t = foldr Table t tt
 
 mkCTable :: [(BindType,Ident)] -> Term -> Term
-mkCTable ids v = foldr ccase v ids where
+mkCTable ids v = foldr ccase v ids where 
   ccase (_,x) t = T TRaw [(PV x,t)]
 
 mkHypo :: Term -> Hypo
@@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of
     filter (`elem` (map fst r1)) (map fst r2) of
       [] -> return (RecType (r1 ++ r2))
       ls -> raise $ render ("clashing labels" <+> hsep ls)
-  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
+  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) 
 
 --plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
@@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel,  typeStr)]
 
 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident
-mkFreshVar olds = varX (maxVarIndex olds + 1)
+mkFreshVar olds = varX (maxVarIndex olds + 1) 
 
 -- | trying to preserve a given symbol
 mkFreshVarX :: [Ident] -> Ident -> Ident
@@ -313,7 +313,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
 maxVarIndex :: [Ident] -> Int
 maxVarIndex = maximum . ((-1):) . map varIndex
 
-mkFreshVars :: Int -> [Ident] -> [Ident]
+mkFreshVars :: Int -> [Ident] -> [Ident] 
 mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
 
 -- | quick hack for refining with var in editor
@@ -413,11 +413,11 @@ patt2term pt = case pt of
   PC c pp   -> mkApp (Con c) (map patt2term pp)
   PP c pp   -> mkApp (QC  c) (map patt2term pp)
 
-  PR r      -> R [assign l (patt2term p) | (l,p) <- r]
+  PR r      -> R [assign l (patt2term p) | (l,p) <- r] 
   PT _ p    -> patt2term p
   PInt i    -> EInt i
   PFloat i  -> EFloat i
-  PString s -> K s
+  PString s -> K s 
 
   PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
   PChar     -> appCons cChar  []                             --- an encoding
@@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op)
 
 -- | to define compositional term functions
 composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp co trm =
+composOp co trm = 
  case trm of
    App c a          -> liftM2 App (co c) (co a)
    Abs b x t        -> liftM (Abs b x) (co t)
@@ -552,13 +552,13 @@ strsFromTerm t = case t of
     v0 <- mapM (strsFromTerm . fst) vs
     c0 <- mapM (strsFromTerm . snd) vs
   --let vs' = zip v0 c0
-    return [strTok (str2strings def) vars |
+    return [strTok (str2strings def) vars | 
               def  <- d0,
-              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
                                                           vv <- sequence v0]
            ]
   FV ts -> mapM strsFromTerm ts >>= return . concat
-  Strs ts -> mapM strsFromTerm ts >>= return . concat
+  Strs ts -> mapM strsFromTerm ts >>= return . concat  
   _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
 
 getTableType :: TInfo -> Err Type
@@ -590,11 +590,11 @@ noExist = FV []
 defaultLinType :: Type
 defaultLinType = mkRecType linLabel [typeStr]
 
--- | normalize records and record types; put s first
+-- normalize records and record types; put s first
 
 sortRec :: [(Label,a)] -> [(Label,a)]
 sortRec = sortBy ordLabel where
-  ordLabel (r1,_) (r2,_) =
+  ordLabel (r1,_) (r2,_) = 
     case (showIdent (label2ident r1), showIdent (label2ident r2)) of
       ("s",_) -> LT
       (_,"s") -> GT
@@ -605,7 +605,7 @@ sortRec = sortBy ordLabel where
 -- | dependency check, detecting circularities and returning topo-sorted list
 
 allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
-allDependencies ism b =
+allDependencies ism b = 
   [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
   where
     opersIn t = case t of

src/compiler/GF/Infra/Ident.hs

@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/15 11:43:33 $
+-- > CVS $Date: 2005/11/15 11:43:33 $ 
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.8 $
 --
@@ -13,18 +13,18 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- ** Identifiers
-  ModuleName(..), moduleNameS,
-  Ident, ident2utf8, showIdent, prefixIdent,
-  -- *** Normal identifiers (returned by the parser)
-  identS, identC, identW,
-  -- *** Special identifiers for internal use
-  identV, identA, identAV,
-  argIdent, isArgIdent, getArgIndex,
-  varStr, varX, isWildIdent, varIndex,
-  -- *** Raw identifiers
-  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-  isPrefixOf, showRawIdent
-) where
+              ModuleName(..), moduleNameS,
+	      Ident, ident2utf8, showIdent, prefixIdent,
+              -- *** Normal identifiers (returned by the parser)
+	      identS, identC, identW,
+              -- *** Special identifiers for internal use
+              identV, identA, identAV,
+	      argIdent, isArgIdent, getArgIndex,
+              varStr, varX, isWildIdent, varIndex,
+              -- *** Raw identifiers
+              RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+              isPrefixOf, showRawIdent
+	     ) where
 
 import qualified Data.ByteString.UTF8 as UTF8
 import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m
 
 -- | the constructors labelled /INTERNAL/ are
 -- internal representation never returned by the parser
-data Ident =
+data Ident = 
    IC  {-# UNPACK #-} !RawIdent                                           -- ^ raw identifier after parsing, resolved in Rename
  | IW                                                                     -- ^ wildcard
 --
@@ -54,7 +54,7 @@ data Ident =
  | IV  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ variable
  | IA  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ argument of cat at position
  | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int   -- ^ /INTERNAL/ argument of cat with bindings at position
---
+-- 
   deriving (Eq, Ord, Show, Read)
 
 -- | Identifiers are stored as UTF-8-encoded bytestrings.
@@ -70,13 +70,14 @@ rawIdentS = Id . pack
 rawIdentC = Id
 showRawIdent = unpack . rawId2utf8
 
-prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
+prefixRawIdent (Id x) (Id y) = Id (BS.append x y) 
 isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
 
 instance Binary RawIdent where
   put = put . rawId2utf8
   get = fmap rawIdentC get
 
+
 -- | This function should be used with care, since the returned ByteString is
 -- UTF-8-encoded.
 ident2utf8 :: Ident -> UTF8.ByteString
@@ -87,7 +88,6 @@ ident2utf8 i = case i of
   IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
   IW -> pack "_"
 
-ident2raw :: Ident -> RawIdent
 ident2raw = Id . ident2utf8
 
 showIdent :: Ident -> String
@@ -95,14 +95,13 @@ showIdent i = unpack $! ident2utf8 i
 
 instance Pretty Ident where pp = pp . showIdent
 
-instance Pretty RawIdent where pp = pp . showRawIdent
-
 identS :: String -> Ident
 identS = identC . rawIdentS
 
 identC :: RawIdent -> Ident
 identW :: Ident
 
+
 prefixIdent :: String -> Ident -> Ident
 prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
 
@@ -113,7 +112,7 @@ identV :: RawIdent -> Int -> Ident
 identA :: RawIdent -> Int -> Ident
 identAV:: RawIdent -> Int -> Int -> Ident
 
-(identC, identV, identA, identAV, identW) =
+(identC, identV, identA, identAV, identW) = 
     (IC,     IV,     IA,     IAV,     IW)
 
 -- | to mark argument variables

src/compiler/GF/Infra/Option.hs

@@ -87,7 +87,8 @@ data Verbosity = Quiet | Normal | Verbose | Debug
 data Phase = Preproc | Convert | Compile | Link
   deriving (Show,Eq,Ord)
 
-data OutputFormat = FmtPGFPretty
+data OutputFormat = FmtLPGF
+                  | FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
                   | FmtJavaScript
@@ -131,13 +132,8 @@ data CFGTransform = CFGNoLR
                   | CFGRemoveCycles
   deriving (Show,Eq,Ord)
 
-data HaskellOption = HaskellNoPrefix
-                   | HaskellGADT
-                   | HaskellLexical
-                   | HaskellConcrete
-                   | HaskellVariants
-                   | HaskellData
-                   | HaskellPGF2
+data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
+                   | HaskellConcrete | HaskellVariants | HaskellData
   deriving (Show,Eq,Ord)
 
 data Warning = WarnMissingLincat
@@ -335,7 +331,7 @@ optDescr =
      Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
         (unlines ["Output format. FMT can be one of:",
                   "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
-                  "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
+                  "Multiple concrete: pgf (default), lpgf, json, js, pgf_pretty, prolog, python, ...", -- gar,
                   "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
                   "Abstract only: haskell, ..."]), -- prolog_abs,
      Option [] ["sisr"] (ReqArg sisrFmt "FMT")
@@ -477,7 +473,8 @@ outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
 outputFormatsExpl =
-    [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
+    [(("lpgf",         FmtLPGF),"Linearisation-only PGF"),
+     (("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)"),
@@ -537,8 +534,7 @@ haskellOptionNames =
      ("lexical",  HaskellLexical),
      ("concrete", HaskellConcrete),
      ("variants", HaskellVariants),
-     ("data",     HaskellData),
-     ("pgf2",     HaskellPGF2)]
+     ("data",     HaskellData)]
 
 -- | This is for bacward compatibility. Since GHC 6.12 we
 -- started using the native Unicode support in GHC but it

src/compiler/GF/Server.hs

@@ -6,7 +6,7 @@ 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)
+import Control.Monad.Error(ErrorT(..),Error(..))
 import System.Random(randomRIO)
 --import System.IO(stderr,hPutStrLn)
 import GF.System.Catch(try)
@@ -108,9 +108,9 @@ handle_fcgi execute1 state0 stateM cache =
 
 -- * Request handler
 -- | Handler monad
-type HM s a = StateT (Q,s) (ExceptT Response IO) a
+type HM s a = StateT (Q,s) (ErrorT Response IO) a
 run :: HM s Response -> (Q,s) -> IO (s,Response)
-run m s = either bad ok =<< runExceptT (runStateT m s)
+run m s = either bad ok =<< runErrorT (runStateT m s)
   where
     bad resp = return (snd s,resp)
     ok (resp,(qs,state)) = return (state,resp)
@@ -123,12 +123,12 @@ put_qs qs = do state <- get_state; put (qs,state)
 put_state state = do qs <- get_qs; put (qs,state)
 
 err :: Response -> HM s a
-err e = StateT $ \ s -> ExceptT $ return $ Left e
+err e = StateT $ \ s -> ErrorT $ return $ Left e
 
 hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
 hmbracket_ pre post m =
     do s <- get
-       e <- liftIO $ bracket_ pre post $ runExceptT $ runStateT m s
+       e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s
        case e of
          Left resp -> err resp
          Right (a,s) -> do put s;return a
@@ -407,6 +407,9 @@ resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n"
 resp500 msg  = Response 500 [plain,xo] $ "Internal error: "++msg++"\n"
 resp501 msg  = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n"
 
+instance Error Response where
+  noMsg = resp500 "no message"
+  strMsg = resp500
 
 -- * Content types
 plain = ct "text/plain" ""

src/compiler/SimpleEditor/JSON.hs

@@ -9,24 +9,14 @@ instance JSON Grammar where
   showJSON (Grammar name extends abstract concretes) =
     makeObj ["basename".=name, "extends".=extends,
              "abstract".=abstract, "concretes".=concretes]
-  readJSON = error "Grammar.readJSON intentionally not defined"
 
 instance JSON Abstract where
   showJSON (Abstract startcat cats funs) =
     makeObj ["startcat".=startcat, "cats".=cats, "funs".=funs]
-  readJSON = error "Abstract.readJSON intentionally not defined"
 
-instance JSON Fun where 
-  showJSON (Fun   name typ) = signature  name typ
-  readJSON = error "Fun.readJSON intentionally not defined"
-
-instance JSON Param where 
-  showJSON (Param name rhs) = definition name rhs
-  readJSON = error "Param.readJSON intentionally not defined"
-
-instance JSON Oper where 
-  showJSON (Oper  name rhs) = definition name rhs
-  readJSON = error "Oper.readJSON intentionally not defined"
+instance JSON Fun   where showJSON (Fun   name typ) = signature  name typ
+instance JSON Param where showJSON (Param name rhs) = definition name rhs
+instance JSON Oper  where showJSON (Oper  name rhs) = definition name rhs
 
 signature  name typ = makeObj ["name".=name,"type".=typ]
 definition name rhs = makeObj ["name".=name,"rhs".=rhs]
@@ -36,15 +26,12 @@ instance JSON Concrete where
     makeObj ["langcode".=langcode, "opens".=opens,
               "params".=params, "opers".=opers,
              "lincats".=lincats, "lins".=lins]
-  readJSON = error "Concrete.readJSON intentionally not defined"
 
 instance JSON Lincat where
   showJSON (Lincat cat lintype) = makeObj ["cat".=cat, "type".=lintype]
-  readJSON = error "Lincat.readJSON intentionally not defined"
 
 instance JSON Lin where
   showJSON (Lin fun args lin) = makeObj ["fun".=fun, "args".=args, "lin".=lin]
-  readJSON = error "Lin.readJSON intentionally not defined"
 
 infix 1 .=
 name .= v = (name,showJSON v)

src/runtime/haskell-bind/CHANGELOG.md

@@ -1,11 +1,7 @@
-## 1.3.0
-
-- Add completion support.
-
 ## 1.2.1
 
-- Remove deprecated `pgf_print_expr_tuple`.
-- Added an API for cloning expressions/types/literals.
+- Remove deprecated pgf_print_expr_tuple
+- Added an API for cloning expressions/types/literals
 
 ## 1.2.0
 

src/runtime/haskell-bind/PGF2.hsc

@@ -43,28 +43,30 @@ module PGF2 (-- * PGF
              mkCId,
              exprHash, exprSize, exprFunctions, exprSubstitute,
              treeProbability,
+
              -- ** Types
              Type, Hypo, BindType(..), startCat,
              readType, showType, showContext,
              mkType, unType,
+
              -- ** Type checking
-             -- | Dynamically-built expressions should always be type-checked before using in other functions,
-             -- as the exceptions thrown by using invalid expressions may not catchable.
              checkExpr, inferExpr, checkType,
+
              -- ** Computing
              compute,
 
              -- * Concrete syntax
              ConcName,Concr,languages,concreteName,languageCode,
+
              -- ** Linearization
              linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,bracketedLinearizeAll,
              FId, BracketedString(..), showBracketedString, flattenBracketedString,
              printName, categoryFields,
+
              alignWords,
              -- ** Parsing
              ParseOutput(..), parse, parseWithHeuristics,
              parseToChart, PArg(..),
-             complete,
              -- ** Sentence Lookup
              lookupSentence,
              -- ** Generation
@@ -178,7 +180,7 @@ languageCode c = unsafePerformIO (peekUtf8CString =<< pgf_language_code (concr c
 
 
 -- | Generates an exhaustive possibly infinite list of
--- all abstract syntax expressions of the given type.
+-- all abstract syntax expressions of the given type. 
 -- The expressions are ordered by their probability.
 generateAll :: PGF -> Type -> [(Expr,Float)]
 generateAll p (Type ctype _) =
@@ -467,21 +469,21 @@ newGraphvizOptions pool opts = do
 -- Functions using Concr
 -- Morpho analyses, parsing & linearization
 
--- | This triple is returned by all functions that deal with
+-- | This triple is returned by all functions that deal with 
 -- the grammar's lexicon. Its first element is the name of an abstract
--- lexical function which can produce a given word or
+-- lexical function which can produce a given word or 
 -- a multiword expression (i.e. this is the lemma).
--- After that follows a string which describes
+-- After that follows a string which describes 
 -- the particular inflection form.
 --
 -- The last element is a logarithm from the
--- the probability of the function. The probability is not
+-- the probability of the function. The probability is not 
 -- conditionalized on the category of the function. This makes it
 -- possible to compare the likelihood of two functions even if they
--- have different types.
+-- have different types. 
 type MorphoAnalysis = (Fun,String,Float)
 
--- | 'lookupMorpho' takes a string which must be a single word or
+-- | 'lookupMorpho' takes a string which must be a single word or 
 -- a multiword expression. It then computes the list of all possible
 -- morphological analyses.
 lookupMorpho :: Concr -> String -> [MorphoAnalysis]
@@ -539,12 +541,12 @@ lookupCohorts lang@(Concr concr master) sent =
                      return ((start,tok,ans,end):cohs)
 
 filterBest :: [(Int,String,[MorphoAnalysis],Int)] -> [(Int,String,[MorphoAnalysis],Int)]
-filterBest ans =
+filterBest ans = 
   reverse (iterate (maxBound :: Int) [(0,0,[],ans)] [] [])
   where
     iterate v0 []                      []  res = res
     iterate v0 []                      new res = iterate v0 new []  res
-    iterate v0 ((_,v,conf,    []):old) new res =
+    iterate v0 ((_,v,conf,    []):old) new res = 
       case compare v0 v of
         LT                                    -> res
         EQ                                    -> iterate v0 old new (merge conf res)
@@ -647,7 +649,7 @@ getAnalysis ref self c_lemma c_anal prob exn = do
 data ParseOutput a
   = ParseFailed Int String         -- ^ The integer is the position in number of unicode characters where the parser failed.
                                    -- The string is the token where the parser have failed.
-  | ParseOk a                      -- ^ If the parsing and the type checking are successful
+  | ParseOk a                      -- ^ If the parsing and the type checking are successful 
                                    -- we get the abstract syntax trees as either a list or a chart.
   | ParseIncomplete                -- ^ The sentence is not complete.
 
@@ -657,9 +659,9 @@ parse lang ty sent = parseWithHeuristics lang ty sent (-1.0) []
 parseWithHeuristics :: Concr      -- ^ the language with which we parse
                     -> Type       -- ^ the start category
                     -> String     -- ^ the input sentence
-                    -> Double     -- ^ the heuristic factor.
-                                  -- A negative value tells the parser
-                                  -- to lookup up the default from
+                    -> Double     -- ^ the heuristic factor. 
+                                  -- A negative value tells the parser 
+                                  -- to lookup up the default from 
                                   -- the grammar flags
                     -> [(Cat, String -> Int -> Maybe (Expr,Float,Int))]
                                   -- ^ a list of callbacks for literal categories.
@@ -713,9 +715,9 @@ parseWithHeuristics lang (Type ctype touchType) sent heuristic callbacks =
 parseToChart :: Concr      -- ^ the language with which we parse
              -> Type       -- ^ the start category
              -> String     -- ^ the input sentence
-             -> Double     -- ^ the heuristic factor.
-                           -- A negative value tells the parser
-                           -- to lookup up the default from
+             -> Double     -- ^ the heuristic factor. 
+                           -- A negative value tells the parser 
+                           -- to lookup up the default from 
                            -- the grammar flags
              -> [(Cat, String -> Int -> Maybe (Expr,Float,Int))]
                            -- ^ a list of callbacks for literal categories.
@@ -884,7 +886,7 @@ lookupSentence lang (Type ctype _) sent =
 
 -- | The oracle is a triple of functions.
 -- The first two take a category name and a linearization field name
--- and they should return True/False when the corresponding
+-- and they should return True/False when the corresponding 
 -- prediction or completion is appropriate. The third function
 -- is the oracle for literals.
 type Oracle = (Maybe (Cat -> String -> Int -> Bool)
@@ -972,67 +974,6 @@ parseWithOracle lang cat sent (predict,complete,literal) =
                          return ep
         Nothing    -> do return nullPtr
 
--- | Returns possible completions of the current partial input.
-complete :: Concr      -- ^ the language with which we parse
-         -> Type       -- ^ the start category
-         -> String     -- ^ the input sentence (excluding token being completed)
-         -> String     -- ^ prefix (partial token being completed)
-         -> ParseOutput [(String, CId, CId, Float)]  -- ^ (token, category, function, probability)
-complete lang (Type ctype _) sent pfx =
-  unsafePerformIO $ do
-    parsePl <- gu_new_pool
-    exn     <- gu_new_exn parsePl
-    sent <- newUtf8CString sent parsePl
-    pfx  <- newUtf8CString pfx parsePl
-    enum <- pgf_complete (concr lang) ctype sent pfx exn parsePl
-    failed <- gu_exn_is_raised exn
-    if failed
-    then do
-      is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError
-      if is_parse_error
-      then do
-        c_err <- (#peek GuExn, data.data) exn
-        c_offset <- (#peek PgfParseError, offset) c_err
-        token_ptr <- (#peek PgfParseError, token_ptr) c_err
-        token_len <- (#peek PgfParseError, token_len) c_err
-        tok <- peekUtf8CStringLen token_ptr token_len
-        gu_pool_free parsePl
-        return (ParseFailed (fromIntegral (c_offset :: CInt)) tok)
-      else do
-        is_exn <- gu_exn_caught exn gu_exn_type_PgfExn
-        if is_exn
-        then do
-          c_msg <- (#peek GuExn, data.data) exn
-          msg <- peekUtf8CString c_msg
-          gu_pool_free parsePl
-          throwIO (PGFError msg)
-        else do
-          gu_pool_free parsePl
-          throwIO (PGFError "Parsing failed")
-    else do
-      fpl <- newForeignPtr gu_pool_finalizer parsePl
-      ParseOk <$> fromCompletions enum fpl
-  where
-    fromCompletions :: Ptr GuEnum -> ForeignPtr GuPool -> IO [(String, CId, CId, Float)]
-    fromCompletions enum fpl =
-      withGuPool $ \tmpPl -> do
-        cmpEntry <- alloca $ \ptr ->
-                      withForeignPtr fpl $ \pl ->
-                        do gu_enum_next enum ptr pl
-                           peek ptr
-        if cmpEntry == nullPtr
-        then do
-          finalizeForeignPtr fpl
-          touchConcr lang
-          return []
-        else do
-          tok <- peekUtf8CString =<< (#peek PgfTokenProb, tok) cmpEntry
-          cat <- peekUtf8CString =<< (#peek PgfTokenProb, cat) cmpEntry
-          fun <- peekUtf8CString =<< (#peek PgfTokenProb, fun) cmpEntry
-          prob <- (#peek PgfTokenProb, prob) cmpEntry
-          toks <- unsafeInterleaveIO (fromCompletions enum fpl)
-          return ((tok, cat, fun, prob) : toks)
-
 -- | Returns True if there is a linearization defined for that function in that language
 hasLinearization :: Concr -> Fun -> Bool
 hasLinearization lang id = unsafePerformIO $
@@ -1106,7 +1047,7 @@ linearizeAll lang e = unsafePerformIO $
 
 -- | Generates a table of linearizations for an expression
 tabularLinearize :: Concr -> Expr -> [(String, String)]
-tabularLinearize lang e =
+tabularLinearize lang e = 
   case tabularLinearizeAll lang e of
     (lins:_) -> lins
     _        -> []
@@ -1197,7 +1138,7 @@ data BracketedString
                                                                                -- the phrase. The 'FId' is an unique identifier for
                                                                                -- every phrase in the sentence. For context-free grammars
                                                                                -- i.e. without discontinuous constituents this identifier
-                                                                               -- is also unique for every bracket. When there are discontinuous
+                                                                               -- is also unique for every bracket. When there are discontinuous 
                                                                                -- phrases then the identifiers are unique for every phrase but
                                                                                -- not for every bracket since the bracket represents a constituent.
                                                                                -- The different constituents could still be distinguished by using
@@ -1207,7 +1148,7 @@ data BracketedString
                                                                                -- The second 'CId' is the name of the abstract function that generated
                                                                                -- this phrase.
 
--- | Renders the bracketed string as a string where
+-- | Renders the bracketed string as a string where 
 -- the brackets are shown as @(S ...)@ where
 -- @S@ is the category.
 showBracketedString :: BracketedString -> String
@@ -1225,7 +1166,7 @@ flattenBracketedString (Bracket _ _ _ _ bss) = concatMap flattenBracketedString
 
 bracketedLinearize :: Concr -> Expr -> [BracketedString]
 bracketedLinearize lang e = unsafePerformIO $
-  withGuPool $ \pl ->
+  withGuPool $ \pl -> 
     do exn <- gu_new_exn pl
        cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl
        failed <- gu_exn_is_raised exn
@@ -1251,7 +1192,7 @@ bracketedLinearize lang e = unsafePerformIO $
 
 bracketedLinearizeAll :: Concr -> Expr -> [[BracketedString]]
 bracketedLinearizeAll lang e = unsafePerformIO $
-  withGuPool $ \pl ->
+  withGuPool $ \pl -> 
     do exn <- gu_new_exn pl
        cts <- pgf_lzr_concretize (concr lang) (expr e) exn pl
        failed <- gu_exn_is_raised exn
@@ -1526,7 +1467,7 @@ type LiteralCallback =
 literalCallbacks :: [(AbsName,[(Cat,LiteralCallback)])]
 literalCallbacks = [("App",[("PN",nerc),("Symb",chunk)])]
 
--- | Named entity recognition for the App grammar
+-- | Named entity recognition for the App grammar 
 -- (based on ../java/org/grammaticalframework/pgf/NercLiteralCallback.java)
 nerc :: LiteralCallback
 nerc pgf (lang,concr) sentence lin_idx offset =

src/runtime/haskell-bind/PGF2/FFI.hsc

@@ -103,7 +103,7 @@ foreign import ccall unsafe "gu/file.h gu_file_in"
 
 foreign import ccall safe  "gu/enum.h gu_enum_next"
   gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
-
+ 
 foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
   gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString
 
@@ -241,7 +241,7 @@ newSequence elem_size pokeElem values pool = do
 type FId = Int
 data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
 
-peekFId :: Ptr a -> IO FId
+peekFId :: Ptr a -> IO FId 
 peekFId c_ccat = do
   c_fid <- (#peek PgfCCat, fid) c_ccat
   return (fromIntegral (c_fid :: CInt))
@@ -256,7 +256,6 @@ data PgfApplication
 data PgfConcr
 type PgfExpr = Ptr ()
 data PgfExprProb
-data PgfTokenProb
 data PgfExprParser
 data PgfFullFormEntry
 data PgfMorphoCallback
@@ -423,9 +422,6 @@ foreign import ccall
 foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
   pgf_parse_with_oracle :: Ptr PgfConcr -> CString -> CString -> Ptr PgfOracleCallback -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
 
-foreign import ccall "pgf/pgf.h pgf_complete"
-  pgf_complete :: Ptr PgfConcr -> PgfType -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
-
 foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
   pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
 

src/runtime/haskell-bind/pgf2.cabal

@@ -1,5 +1,5 @@
 name: pgf2
-version: 1.3.0
+version: 1.2.1
 synopsis: Bindings to the C version of the PGF runtime
 description:
   GF, Grammatical Framework, is a programming language for multilingual grammar applications.
@@ -9,7 +9,8 @@ homepage: https://www.grammaticalframework.org
 license: LGPL-3
 license-file: LICENSE
 author: Krasimir Angelov
-category: Natural Language Processing
+maintainer: kr.angelov@gmail.com
+category: Language
 build-type: Simple
 extra-source-files: CHANGELOG.md, README.md
 cabal-version: >=1.10

src/runtime/haskell/Data/Binary/Builder.hs

@@ -68,7 +68,7 @@ import qualified Data.ByteString.Lazy as L
 import Data.ByteString.Base (inlinePerformIO)
 import qualified Data.ByteString.Base as S
 #else
-import Data.ByteString.Internal (accursedUnutterablePerformIO)
+import Data.ByteString.Internal (inlinePerformIO)
 import qualified Data.ByteString.Internal as S
 --import qualified Data.ByteString.Lazy.Internal as L
 #endif
@@ -199,7 +199,7 @@ defaultSize = 32 * k - overhead
 
 -- | Sequence an IO operation on the buffer
 unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
-unsafeLiftIO f =  Builder $ \ k buf -> accursedUnutterablePerformIO $ do
+unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do
     buf' <- f buf
     return (k buf')
 {-# INLINE unsafeLiftIO #-}

src/runtime/haskell/Data/Binary/Get.hs

@@ -423,7 +423,7 @@ readN n f = fmap f $ getBytes n
 getPtr :: Storable a => Int -> Get a
 getPtr n = do
     (fp,o,_) <- readN n B.toForeignPtr
-    return . B.accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
+    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
 {- INLINE getPtr -}
 
 ------------------------------------------------------------------------

src/runtime/haskell/LPGF.hs

@@ -0,0 +1,368 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Linearisation-only grammar format.
+-- Closely follows description in Section 2 of Angelov, Bringert, Ranta (2009):
+-- "PGF: A Portable Run-Time Format for Type-Theoretical Grammars".
+-- http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.640.6330&rep=rep1&type=pdf
+module LPGF where
+
+import PGF (Language)
+import PGF.CId
+import PGF.Expr (Expr)
+import PGF.Tree (Tree (..), expr2tree, prTree)
+
+import qualified Control.Exception as EX
+import Control.Monad (liftM, liftM2, forM_)
+import qualified Control.Monad.Writer as CMW
+import Data.Char (toUpper)
+import Data.Binary (Binary, put, get, putWord8, getWord8, encodeFile, decodeFile)
+import Data.Either (isLeft)
+import qualified Data.IntMap as IntMap
+import Data.List (isPrefixOf)
+import qualified Data.Map.Strict as Map
+import Text.Printf (printf)
+
+import Prelude hiding ((!!))
+import qualified Prelude
+
+-- | Linearisation-only PGF
+data LPGF = LPGF {
+  absname   :: CId,
+  abstract  :: Abstract,
+  concretes :: Map.Map CId Concrete
+} deriving (Show)
+
+-- | Abstract syntax (currently empty)
+data Abstract = Abstract {
+} deriving (Show)
+
+-- | Concrete syntax
+data Concrete = Concrete {
+  toks    :: IntMap.IntMap String, -- ^ all strings are stored exactly once here
+  -- lincats :: Map.Map CId LinType, -- ^ a linearization type for each category
+  lins    :: Map.Map CId LinFun  -- ^ a linearization function for each function
+} deriving (Show)
+
+-- | Abstract function type
+-- data Type = Type [CId] CId
+--   deriving (Show)
+
+-- -- | Linearisation type
+-- data LinType =
+--     StrType
+--   | IxType Int
+--   | ProductType [LinType]
+--   deriving (Show)
+
+-- | Linearisation function
+data LinFun =
+  -- Additions
+    Error String -- ^ a runtime error, should probably not be supported at all
+  | Bind -- ^ join adjacent tokens
+  | Space -- ^ space between adjacent tokens
+  | Capit -- ^ capitalise next character
+  | AllCapit -- ^ capitalise next word
+  | Pre [([String], LinFun)] LinFun
+  | Missing CId -- ^ missing definition (inserted at runtime)
+
+  -- From original definition in paper
+  | Empty
+  | Token String
+  | Concat LinFun LinFun
+  | Ix Int
+  | Tuple [LinFun]
+  | Projection LinFun LinFun
+  | Argument Int
+
+  -- For reducing LPGF file when stored
+  | PreIx [(Int, LinFun)] LinFun -- ^ index into `toks` map (must apply read to convert to list)
+  | TokenIx Int -- ^ index into `toks` map
+
+  deriving (Show, Read)
+
+instance Binary LPGF where
+  put lpgf = do
+    put (absname lpgf)
+    put (abstract lpgf)
+    put (concretes lpgf)
+  get = do
+    an <- get
+    abs <- get
+    concs <- get
+    return $ LPGF {
+      absname = an,
+      abstract = abs,
+      concretes = concs
+    }
+
+instance Binary Abstract where
+  put abs = return ()
+  get = return $ Abstract {}
+
+instance Binary Concrete where
+  put concr = do
+    put (toks concr)
+    put (lins concr)
+  get = do
+    ts <- get
+    ls <- get
+    return $ Concrete {
+      toks = ts,
+      lins = ls
+    }
+
+instance Binary LinFun where
+  put = \case
+    Error e          -> putWord8 0 >> put e
+    Bind             -> putWord8 1
+    Space            -> putWord8 2
+    Capit            -> putWord8 3
+    AllCapit         -> putWord8 4
+    Pre ps d         -> putWord8 5 >> put (ps,d)
+    Missing f        -> putWord8 13 >> put f
+
+    Empty            -> putWord8 6
+    Token t          -> putWord8 7 >> put t
+    Concat l1 l2     -> putWord8 8 >> put (l1,l2)
+    Ix i             -> putWord8 9 >> put i
+    Tuple ls         -> putWord8 10 >> put ls
+    Projection l1 l2 -> putWord8 11 >> put (l1,l2)
+    Argument i       -> putWord8 12 >> put i
+
+    PreIx ps d       -> putWord8 15 >> put (ps,d)
+    TokenIx i        -> putWord8 14 >> put i
+
+  get = do
+    tag <- getWord8
+    case tag of
+      0  -> liftM  Error get
+      1  -> return Bind
+      2  -> return Space
+      3  -> return Capit
+      4  -> return AllCapit
+      5  -> liftM2 Pre get get
+      13 -> liftM  Missing get
+
+      6  -> return Empty
+      7  -> liftM  Token get
+      8  -> liftM2 Concat get get
+      9  -> liftM  Ix get
+      10 -> liftM  Tuple get
+      11 -> liftM2 Projection get get
+      12 -> liftM  Argument get
+
+      15 -> liftM2 PreIx get get
+      14 -> liftM  TokenIx get
+      _  -> fail "Failed to decode LPGF binary format"
+
+abstractName :: LPGF -> CId
+abstractName = absname
+
+encodeFile :: FilePath -> LPGF -> IO ()
+encodeFile = Data.Binary.encodeFile
+
+readLPGF :: FilePath -> IO LPGF
+readLPGF = Data.Binary.decodeFile
+
+-- | Main linearize function, to 'String'
+linearize :: LPGF -> Language -> Expr -> String
+linearize lpgf lang =
+  case Map.lookup lang (concretes lpgf) of
+    Just concr -> linearizeConcrete concr
+    Nothing -> error $ printf "Unknown language: %s" (showCId lang)
+
+-- | Language-specific linearize function, to 'String'
+linearizeConcrete :: Concrete -> Expr -> String
+linearizeConcrete concr expr = lin2string $ lin (expr2tree expr)
+  where
+    lin :: Tree -> LinFun
+    lin tree = case tree of
+      Fun f as ->
+        case Map.lookup f (lins concr) of
+          Just t -> eval cxt t
+            where cxt = Context { cxToks = toks concr, cxArgs = map lin as }
+          _ -> Missing f
+      x -> error $ printf "Cannot lin: %s" (prTree x)
+
+-- | Run a compatation and catch any exception/errors.
+-- Ideally this library should never throw exceptions, but we're still in development...
+try :: a -> IO (Either String a)
+try comp = do
+  let f = Right <$> EX.evaluate comp
+  EX.catch f (\(e :: EX.SomeException) -> return $ Left (show e))
+
+-- | Evaluation context
+data Context = Context {
+  cxArgs :: [LinFun], -- ^  is a sequence of terms
+  cxToks :: IntMap.IntMap String -- ^ token map
+}
+
+-- | Operational semantics
+eval :: Context -> LinFun -> LinFun
+eval cxt t = case t of
+  Error err -> error err
+  Pre pts df -> Pre pts' df'
+    where
+      pts' = [(pfxs, eval cxt t) | (pfxs, t) <- pts]
+      df' = eval cxt df
+
+  Concat s t -> Concat v w
+    where
+      v = eval cxt s
+      w = eval cxt t
+  Tuple ts -> Tuple vs
+    where vs = map (eval cxt) ts
+  Projection t u ->
+    case (eval cxt t, eval cxt u) of
+      (Missing f, _) -> Missing f
+      (_, Missing f) -> Missing f
+      (Tuple vs, Ix i) -> vs !! (i-1)
+      (t', tv@(Tuple _)) -> eval cxt $ foldl Projection t' (flattenTuple tv)
+      (t',u') -> error $ printf "Incompatible projection:\n- %s\n⇓ %s\n- %s\n⇓ %s" (show t) (show t') (show u) (show u')
+  Argument i -> cxArgs cxt !! (i-1)
+
+  PreIx pts df -> Pre pts' df'
+    where
+      pts' = [(pfxs, eval cxt t) | (ix, t) <- pts, let pfxs = maybe [] read $ IntMap.lookup ix (cxToks cxt)]
+      df' = eval cxt df
+  TokenIx i -> maybe Empty Token $ IntMap.lookup i (cxToks cxt)
+
+  _ -> t
+
+flattenTuple :: LinFun -> [LinFun]
+flattenTuple = \case
+  Tuple vs -> concatMap flattenTuple vs
+  lf -> [lf]
+
+-- | Turn concrete syntax terms into an actual string.
+-- This is done in two passes, first to flatten concats & evaluate pre's, then to
+-- apply BIND and other predefs.
+lin2string :: LinFun -> String
+lin2string lf = unwords $ join $ flatten [lf]
+  where
+    -- Process bind et al into final token list
+    join :: [Either LinFun String] -> [String]
+    join elt = case elt of
+      Right tok:Left Bind:ls ->
+        case join ls of
+          next:ls' -> tok : next : ls'
+          _ -> []
+      Right tok:ls -> tok : join ls
+      Left Space:ls -> join ls
+      Left Capit:ls ->
+        case join ls of
+          next:ls' -> (toUpper (head next) : tail next) : ls'
+          _ -> []
+      Left AllCapit:ls ->
+        case join ls of
+          next:ls' -> map toUpper next : ls'
+          _ -> []
+      Left (Missing cid):ls -> join (Right (printf "[%s]" (show cid)) : ls)
+      [] -> []
+      x -> error $ printf "Unhandled term in lin2string: %s" (show x)
+
+    -- Process concats, tuples, pre into flat list
+    flatten :: [LinFun] -> [Either LinFun String]
+    flatten [] = []
+    flatten (l:ls) = case l of
+      Empty -> flatten ls
+      Token "" -> flatten ls
+      Token tok -> Right tok : flatten ls
+      Concat l1 l2 -> flatten (l1 : l2 : ls)
+      Tuple [l] -> flatten (l:ls)
+      Tuple (l:_) -> flatten (l:ls) -- unselected table, just choose first option (see e.g. FoodsJpn)
+      Pre pts df ->
+        let
+          f = flatten ls
+          ch = case dropWhile isLeft f of
+            Right next:_ ->
+              let matches = [ l | (pfxs, l) <- pts, any (`isPrefixOf` next) pfxs ]
+              in  if null matches then df else head matches
+            _ -> df
+        in flatten (ch:ls)
+      x -> Left x : flatten ls
+
+-- | List indexing with more verbose error messages
+(!!) :: (Show a) => [a] -> Int -> a
+(!!) xs i
+  | i < 0 = error $ printf "!!: index %d too small for list: %s" i (show xs)
+  | i > length xs - 1 = error $ printf "!!: index %d too large for list: %s" i (show xs)
+  | otherwise = xs Prelude.!! i
+
+isIx :: LinFun -> Bool
+isIx (Ix _) = True
+isIx _ = False
+
+-- | Helper for building concat trees
+mkConcat :: [LinFun] -> LinFun
+mkConcat [] = Empty
+mkConcat [x] = x
+mkConcat xs = foldl1 Concat xs
+
+-- | Helper for unfolding concat trees
+unConcat :: LinFun -> [LinFun]
+unConcat (Concat l1 l2) = concatMap unConcat [l1, l2]
+unConcat lf = [lf]
+
+------------------------------------------------------------------------------
+-- Pretty-printing
+
+type Doc = CMW.Writer [String] ()
+
+render :: Doc -> String
+render = unlines . CMW.execWriter
+
+class PP a where
+  pp :: a -> Doc
+
+instance PP LPGF where
+  pp (LPGF _ _ cncs) = mapM_ pp cncs
+
+instance PP Concrete where
+  pp (Concrete toks lins) = do
+    forM_ (IntMap.toList toks) $ \(i,tok) ->
+      CMW.tell [show i ++ " " ++ tok]
+    CMW.tell [""]
+    forM_ (Map.toList lins) $ \(cid,lin) -> do
+      CMW.tell ["# " ++ showCId cid]
+      pp lin
+      CMW.tell [""]
+
+instance PP LinFun where
+  pp = pp' 0
+    where
+      pp' n = \case
+        Pre ps d -> do
+          p "Pre"
+          CMW.tell [ replicate (2*(n+1)) ' ' ++ show p | p <- ps ]
+          pp' (n+1) d
+
+        c@(Concat l1 l2) -> do
+          let ts = unConcat c
+          if any isDeep ts
+          then do
+            p "Concat"
+            mapM_ (pp' (n+1)) ts
+          else
+            p $ "Concat " ++ show ts
+        Tuple ls | any isDeep ls -> do
+          p "Tuple"
+          mapM_ (pp' (n+1)) ls
+        Projection l1 l2 | isDeep l1 || isDeep l2 -> do
+          p "Projection"
+          pp' (n+1) l1
+          pp' (n+1) l2
+        t -> p $ show t
+        where
+          p :: String -> Doc
+          p t = CMW.tell [ replicate (2*n) ' ' ++ t ]
+
+      isDeep = not . isTerm
+      isTerm = \case
+        Pre _ _ -> False
+        Concat _ _ -> False
+        Tuple _ -> False
+        Projection _ _ -> False
+        _ -> True

src/runtime/haskell/PGF/TypeCheck.hs

@@ -41,7 +41,7 @@ import Control.Applicative
 import Control.Monad
 --import Control.Monad.Identity
 import Control.Monad.State
-import Control.Monad.Except
+import Control.Monad.Error
 import Text.PrettyPrint
 
 -----------------------------------------------------

src/runtime/haskell/pgf.cabal

@@ -1,5 +1,5 @@
 name: pgf
-version: 3.10.1-git
+version: 3.10
 
 cabal-version: >= 1.20
 build-type: Simple
@@ -9,21 +9,20 @@ synopsis: Grammatical Framework
 description: A library for interpreting the Portable Grammar Format (PGF)
 homepage: http://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC==8.4.4
+maintainer: Thomas Hallgren
+tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2
 
-library
-  default-language: Haskell2010
-  build-depends:
-    array,
-    base >= 4.6 && <5,
-    bytestring,
-    containers,
-    -- exceptions,
-    ghc-prim,
-    mtl,
-    pretty,
-    random,
-    utf8-string
+Library
+  default-language:    Haskell2010
+  build-depends: base >= 4.6 && <5,
+                 array,
+                 containers,
+                 bytestring,
+                 utf8-string,
+                 random,
+                 pretty,
+                 mtl,
+                 exceptions
 
   other-modules:
     -- not really part of GF but I have changed the original binary library
@@ -38,6 +37,7 @@ library
 --if impl(ghc>=7.8)
 --  ghc-options: +RTS -A20M -RTS
   ghc-prof-options: -fprof-auto
+  extensions:
 
   exposed-modules:
     PGF

src/server/PGFService.hs

@@ -151,37 +151,29 @@ getFile get path =
 cpgfMain qsem command (t,(pgf,pc)) =
   case command of
     "c-parse"       -> withQSem qsem $
-                       out t=<< join (parse # input % cat % start % limit % treeopts)
+                       out t=<< join (parse # input % start % limit % treeopts)
     "c-parseToChart"-> withQSem qsem $
-                       out t=<< join (parseToChart # input % cat % limit)
+                       out t=<< join (parseToChart # input % limit)
     "c-linearize"   -> out t=<< lin # tree % to
     "c-bracketedLinearize"
                     -> out t=<< bracketedLin # tree % to
     "c-linearizeAll"-> out t=<< linAll # tree % to
     "c-translate"   -> withQSem qsem $
-                       out t=<<join(trans # input % cat % to % start % limit%treeopts)
+                       out t=<<join(trans # input % to % start % limit%treeopts)
     "c-lookupmorpho"-> out t=<< morpho # from1 % textInput
     "c-lookupcohorts"->out t=<< cohorts # from1 % getInput "filter" % textInput
     "c-flush"       -> out t=<< flush
     "c-grammar"     -> out t grammar
     "c-abstrtree"   -> outputGraphviz=<< C.graphvizAbstractTree pgf C.graphvizDefaults # tree
     "c-parsetree"   -> outputGraphviz=<< (\cnc -> C.graphvizParseTree cnc C.graphvizDefaults) . snd # from1 %tree
-    "c-wordforword" -> out t =<< wordforword # input % cat % to
+    "c-wordforword" -> out t =<< wordforword # input % to
     _               -> badRequest "Unknown command" command
   where
     flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
                         performGC
                         return $ showJSON ()
 
-    cat :: CGI C.Type
-    cat =
-       do mcat  <- getInput1 "cat"
-          case mcat of
-            Nothing -> return (C.startCat pgf)
-            Just cat -> case C.readType cat of
-                          Nothing  -> badRequest "Bad category" cat
-                          Just typ -> return typ
-
+    cat = C.startCat pgf
     langs = C.languages pgf
 
     grammar = showJSON $ makeObj
@@ -192,8 +184,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
       where
         languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
 
-    parse input@((from,_),_) cat start mlimit (trie,json) =
-        do r <- parse' cat start mlimit input
+    parse input@((from,_),_) start mlimit (trie,json) =
+        do r <- parse' start mlimit input
            return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
 
     jsonParseResult json = either bad good
@@ -203,7 +195,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
         tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
 
     -- Without caching parse results:
-    parse' cat start mlimit ((from,concr),input) =
+    parse' start mlimit ((from,concr),input) =
         case C.parseWithHeuristics concr cat input (-1) callbacks of
           C.ParseOk ts        -> return (Right (maybe id take mlimit (drop start ts)))
           C.ParseFailed _ tok -> return (Left tok)
@@ -229,7 +221,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                              -- remove unused parse results after 2 minutes
 -}
 
-    parseToChart ((from,concr),input) cat mlimit =
+    parseToChart ((from,concr),input) mlimit =
       do r <- case C.parseToChart concr cat input (-1) callbacks (fromMaybe 5 mlimit) of
                 C.ParseOk chart     -> return (good chart)
                 C.ParseFailed _ tok -> return (bad tok)
@@ -270,8 +262,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
     bracketedLin' tree (tos,unlex) =
         [makeObj ["to".=to,"brackets".=showJSON (C.bracketedLinearize c tree)]|(to,c)<-tos]
 
-    trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
-      do parses <- parse' cat start mlimit input
+    trans input@((from,_),_) to start mlimit (trie,jsontree) =
+      do parses <- parse' start mlimit input
          return $
            showJSON [ makeObj ["from".=from,
                                "translations".= jsonParses parses]]
@@ -305,7 +297,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                       _              -> id)
                                      (C.lookupCohorts concr input)]
 
-    wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
+    wordforword input@((from,_),_) = jsonWFW from . wordforword' input
 
     jsonWFW from rs =
       showJSON
@@ -315,7 +307,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                         [makeObj["to".=to,"text".=text]
                                          | (to,text)<-rs]]]]]
 
-    wordforword' inp@((from,concr),input) cat (tos,unlex) =
+    wordforword' inp@((from,concr),input) (tos,unlex) =
         [(to,unlex . unwords $ map (lin_word' c) pws)
          |let pws=map parse_word' (words input),(to,c)<-tos]
       where
@@ -1032,7 +1024,6 @@ instance JSON PGF.Trie where
     showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf
 --  showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
     showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts]
-    readJSON = error "PGF.Trie.readJSON intentionally not defined"
 
 instance JSON PGF.CId where
     readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage

stack-ghc7.10.3.yaml

@@ -4,16 +4,9 @@ extra-deps:
 - happy-1.19.9
 - alex-3.2.4
 - transformers-compat-0.6.5
-- directory-1.2.3.0
-- process-1.2.3.0@sha256:ee08707f1c806ad4a628c5997d8eb6e66d2ae924283548277d85a66341d57322,1806
 
 allow-newer: true
 
 flags:
   transformers-compat:
-    four: true
-#   gf:
-#     c-runtime: true
-#
-# extra-lib-dirs:
-#   - /usr/local/lib
+    four: true

stack-ghc8.0.2.yaml

@@ -1,7 +1 @@
 resolver: lts-9.21 # ghc 8.0.2
-
-# flags:
-#   gf:
-#     c-runtime: true
-# extra-lib-dirs:
-#   - /usr/local/lib

stack-ghc8.2.2.yaml

@@ -4,9 +4,3 @@ extra-deps:
 - cgi-3001.3.0.3
 - httpd-shed-0.4.0.3
 - exceptions-0.10.2
-
-# flags:
-#   gf:
-#     c-runtime: true
-# extra-lib-dirs:
-#   - /usr/local/lib

stack-ghc8.4.4.yaml

@@ -2,9 +2,3 @@ resolver: lts-12.26 # ghc 8.4.4
 
 extra-deps:
 - cgi-3001.3.0.3
-
-# flags:
-#   gf:
-#     c-runtime: true
-# extra-lib-dirs:
-#   - /usr/local/lib

stack-ghc8.6.5.yaml

@@ -4,9 +4,3 @@ extra-deps:
 - network-2.6.3.6
 - httpd-shed-0.4.0.3
 - cgi-3001.5.0.0
-
-# flags:
-#   gf:
-#     c-runtime: true
-# extra-lib-dirs:
-#   - /usr/local/lib

stack-ghc8.8.4.yaml

@@ -7,8 +7,3 @@ extra-deps:
 - json-0.10@sha256:d9fc6b07ce92b8894825a17d2cf14799856767eb30c8bf55962baa579207d799,3210
 - multipart-0.2.0@sha256:b8770e3ff6089be4dd089a8250894b31287cca671f3d258190a505f9351fa8a9,1084
 
-# flags:
-#   gf:
-#     c-runtime: true
-# extra-lib-dirs:
-#   - /usr/local/lib

stack.yaml

@@ -1,16 +1,9 @@
 # This default stack file is a copy of stack-ghc8.6.5.yaml
-# But committing a symlink can be problematic on Windows, so it's a real copy.
-# See: https://github.com/GrammaticalFramework/gf-core/pull/106
+# But committing a symlink is probably a bad idea, so it's a real copy
 
 resolver: lts-14.27 # ghc 8.6.5
 
 extra-deps:
 - network-2.6.3.6
 - httpd-shed-0.4.0.3
-- cgi-3001.5.0.0
-
-# flags:
-#   gf:
-#     c-runtime: true
-# extra-lib-dirs:
-#   - /usr/local/lib
+- cgi-3001.5.0.0

testsuite/canonical/.gitignore

@@ -1 +0,0 @@
-canonical/

testsuite/canonical/gold/FoodsFin.gf

@@ -1,102 +0,0 @@
-concrete FoodsFin of Foods = {
-param ParamX_Number = ParamX_Sg | ParamX_Pl;
-param Prelude_Bool = Prelude_False | Prelude_True;
-param ResFin_Agr = ResFin_Ag ParamX_Number ParamX_Person | ResFin_AgPol;
-param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
-param ResFin_Harmony = ResFin_Back | ResFin_Front;
-param ResFin_NForm =
-    ResFin_NCase ParamX_Number ResFin_Case | ResFin_NComit | ResFin_NInstruct |
-    ResFin_NPossNom ParamX_Number | ResFin_NPossGen ParamX_Number |
-    ResFin_NPossTransl ParamX_Number | ResFin_NPossIllat ParamX_Number |
-    ResFin_NCompound;
-param ResFin_Case =
-    ResFin_Nom | ResFin_Gen | ResFin_Part | ResFin_Transl | ResFin_Ess |
-    ResFin_Iness | ResFin_Elat | ResFin_Illat | ResFin_Adess | ResFin_Ablat |
-    ResFin_Allat | ResFin_Abess;
-param ResFin_NPForm = ResFin_NPCase ResFin_Case | ResFin_NPAcc | ResFin_NPSep;
-lincat Comment = {s : Str};
-       Item =
-           {s : ResFin_NPForm => Str; a : ResFin_Agr; isNeg : Prelude_Bool;
-            isPron : Prelude_Bool};
-       Kind =
-           {s : ResFin_NForm => Str; h : ResFin_Harmony;
-            postmod : ParamX_Number => Str};
-       Quality =
-           {s : Prelude_Bool => ResFin_NForm => Str; hasPrefix : Prelude_Bool;
-            p : Str};
-lin Expensive =
-        {s =
-           table {Prelude_False =>
-                    table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
-                           ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
-                           ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
-                           ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
-                           ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
-                           ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
-                           ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
-                           ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
-                           ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
-                           ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
-                           ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
-                           ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
-                           ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
-                           ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
-                           ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
-                           ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
-                           ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
-                           ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
-                           ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
-                           ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
-                           ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
-                           ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
-                           ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
-                           ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
-                           ResFin_NComit => "kalliine";
-                           ResFin_NInstruct => "kalliin";
-                           ResFin_NPossNom ParamX_Sg => "kallii";
-                           ResFin_NPossNom ParamX_Pl => "kallii";
-                           ResFin_NPossGen ParamX_Sg => "kallii";
-                           ResFin_NPossGen ParamX_Pl => "kalliide";
-                           ResFin_NPossTransl ParamX_Sg => "kalliikse";
-                           ResFin_NPossTransl ParamX_Pl => "kalliikse";
-                           ResFin_NPossIllat ParamX_Sg => "kalliisee";
-                           ResFin_NPossIllat ParamX_Pl => "kalliisii";
-                           ResFin_NCompound => "kallis"};
-                  Prelude_True =>
-                    table {ResFin_NCase ParamX_Sg ResFin_Nom => "kallis";
-                           ResFin_NCase ParamX_Sg ResFin_Gen => "kalliin";
-                           ResFin_NCase ParamX_Sg ResFin_Part => "kallista";
-                           ResFin_NCase ParamX_Sg ResFin_Transl => "kalliiksi";
-                           ResFin_NCase ParamX_Sg ResFin_Ess => "kalliina";
-                           ResFin_NCase ParamX_Sg ResFin_Iness => "kalliissa";
-                           ResFin_NCase ParamX_Sg ResFin_Elat => "kalliista";
-                           ResFin_NCase ParamX_Sg ResFin_Illat => "kalliiseen";
-                           ResFin_NCase ParamX_Sg ResFin_Adess => "kalliilla";
-                           ResFin_NCase ParamX_Sg ResFin_Ablat => "kalliilta";
-                           ResFin_NCase ParamX_Sg ResFin_Allat => "kalliille";
-                           ResFin_NCase ParamX_Sg ResFin_Abess => "kalliitta";
-                           ResFin_NCase ParamX_Pl ResFin_Nom => "kalliit";
-                           ResFin_NCase ParamX_Pl ResFin_Gen => "kalliiden";
-                           ResFin_NCase ParamX_Pl ResFin_Part => "kalliita";
-                           ResFin_NCase ParamX_Pl ResFin_Transl => "kalliiksi";
-                           ResFin_NCase ParamX_Pl ResFin_Ess => "kalliina";
-                           ResFin_NCase ParamX_Pl ResFin_Iness => "kalliissa";
-                           ResFin_NCase ParamX_Pl ResFin_Elat => "kalliista";
-                           ResFin_NCase ParamX_Pl ResFin_Illat => "kalliisiin";
-                           ResFin_NCase ParamX_Pl ResFin_Adess => "kalliilla";
-                           ResFin_NCase ParamX_Pl ResFin_Ablat => "kalliilta";
-                           ResFin_NCase ParamX_Pl ResFin_Allat => "kalliille";
-                           ResFin_NCase ParamX_Pl ResFin_Abess => "kalliitta";
-                           ResFin_NComit => "kalliine";
-                           ResFin_NInstruct => "kalliin";
-                           ResFin_NPossNom ParamX_Sg => "kallii";
-                           ResFin_NPossNom ParamX_Pl => "kallii";
-                           ResFin_NPossGen ParamX_Sg => "kallii";
-                           ResFin_NPossGen ParamX_Pl => "kalliide";
-                           ResFin_NPossTransl ParamX_Sg => "kalliikse";
-                           ResFin_NPossTransl ParamX_Pl => "kalliikse";
-                           ResFin_NPossIllat ParamX_Sg => "kalliisee";
-                           ResFin_NPossIllat ParamX_Pl => "kalliisii";
-                           ResFin_NCompound => "kallis"}};
-         hasPrefix = Prelude_False; p = ""};
-}

testsuite/canonical/gold/PhrasebookBul.gf

@@ -1,29 +0,0 @@
-concrete PhrasebookBul of Phrasebook = {
-param Prelude_Bool = Prelude_False | Prelude_True;
-param ResBul_AGender = ResBul_AMasc ResBul_Animacy | ResBul_AFem | ResBul_ANeut;
-param ResBul_Animacy = ResBul_Human | ResBul_NonHuman;
-param ResBul_Case = ResBul_Acc | ResBul_Dat | ResBul_WithPrep | ResBul_CPrep;
-param ResBul_NForm =
-    ResBul_NF ParamX_Number ResBul_Species | ResBul_NFSgDefNom |
-    ResBul_NFPlCount | ResBul_NFVocative;
-param ParamX_Number = ParamX_Sg | ParamX_Pl;
-param ResBul_Species = ResBul_Indef | ResBul_Def;
-lincat PlaceKind =
-           {at : {s : Str; c : ResBul_Case}; isPl : Prelude_Bool;
-            name : {s : ResBul_NForm => Str; g : ResBul_AGender};
-            to : {s : Str; c : ResBul_Case}};
-       VerbPhrase = {s : Str};
-lin Airport =
-        {at = {s = "на"; c = ResBul_Acc}; isPl = Prelude_False;
-         name =
-           {s =
-              table {ResBul_NF ParamX_Sg ResBul_Indef => "летище";
-                     ResBul_NF ParamX_Sg ResBul_Def => "летището";
-                     ResBul_NF ParamX_Pl ResBul_Indef => "летища";
-                     ResBul_NF ParamX_Pl ResBul_Def => "летищата";
-                     ResBul_NFSgDefNom => "летището";
-                     ResBul_NFPlCount => "летища";
-                     ResBul_NFVocative => "летище"};
-            g = ResBul_ANeut};
-         to = {s = "до"; c = ResBul_CPrep}};
-}

testsuite/canonical/gold/PhrasebookGer.gf

@@ -1,251 +0,0 @@
-concrete PhrasebookGer of Phrasebook = {
-param Prelude_Bool = Prelude_False | Prelude_True;
-param ResGer_Agr = ResGer_Ag ResGer_Gender ParamX_Number ParamX_Person;
-param ParamX_Number = ParamX_Sg | ParamX_Pl;
-param ParamX_Person = ParamX_P1 | ParamX_P2 | ParamX_P3;
-param ResGer_Gender = ResGer_Masc | ResGer_Fem | ResGer_Neutr;
-param ResGer_Control = ResGer_SubjC | ResGer_ObjC | ResGer_NoC;
-param ResGer_PCase = ResGer_NPC ResGer_Case | ResGer_NPP ResGer_CPrep;
-param ResGer_CPrep =
-    ResGer_CAnDat | ResGer_CInAcc | ResGer_CInDat | ResGer_CZuDat |
-    ResGer_CVonDat;
-param ResGer_Case = ResGer_Nom | ResGer_Acc | ResGer_Dat | ResGer_Gen;
-param ResGer_VAux = ResGer_VHaben | ResGer_VSein;
-param ResGer_VForm =
-    ResGer_VInf Prelude_Bool | ResGer_VFin Prelude_Bool ResGer_VFormFin |
-    ResGer_VImper ParamX_Number | ResGer_VPresPart ResGer_AForm |
-    ResGer_VPastPart ResGer_AForm;
-param ResGer_AForm = ResGer_APred | ResGer_AMod ResGer_GenNum ResGer_Case;
-param ResGer_GenNum = ResGer_GSg ResGer_Gender | ResGer_GPl;
-param ResGer_VFormFin =
-    ResGer_VPresInd ParamX_Number ParamX_Person |
-    ResGer_VPresSubj ParamX_Number ParamX_Person;
-param ResGer_VType = ResGer_VAct | ResGer_VRefl ResGer_Case;
-lincat PlaceKind = {s : Str};
-       VerbPhrase =
-           {s :
-              {s : ResGer_VForm => Str; aux : ResGer_VAux; particle : Str;
-               prefix : Str; vtype : ResGer_VType};
-            a1 : Str; a2 : Str; adj : Str; ext : Str;
-            inf : {s : Str; ctrl : ResGer_Control; isAux : Prelude_Bool};
-            infExt : Str; isAux : Prelude_Bool;
-            nn :
-              ResGer_Agr =>
-              {p1 : Str; p2 : Str; p3 : Str; p4 : Str; p5 : Str; p6 : Str};
-            subjc :
-              {s : Str; c : ResGer_PCase; isPrep : Prelude_Bool; s2 : Str}};
-lin VRead =
-        {s =
-           {s =
-              table {ResGer_VInf Prelude_False => "lesen";
-                     ResGer_VInf Prelude_True => "zu" ++ "lesen";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresInd ParamX_Sg ParamX_P1) =>
-                       "lese";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresInd ParamX_Sg ParamX_P2) =>
-                       "liest";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresInd ParamX_Sg ParamX_P3) =>
-                       "liest";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresInd ParamX_Pl ParamX_P1) =>
-                       "lesen";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresInd ParamX_Pl ParamX_P2) =>
-                       "lest";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresInd ParamX_Pl ParamX_P3) =>
-                       "lesen";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
-                       "lese";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
-                       "lesest";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
-                       "lese";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
-                       "lesen";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
-                       "leset";
-                     ResGer_VFin Prelude_False
-                                 (ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
-                       "lesen";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresInd ParamX_Sg ParamX_P1) =>
-                       "lese";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresInd ParamX_Sg ParamX_P2) =>
-                       "liest";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresInd ParamX_Sg ParamX_P3) =>
-                       "liest";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresInd ParamX_Pl ParamX_P1) =>
-                       "lesen";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresInd ParamX_Pl ParamX_P2) =>
-                       "lest";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresInd ParamX_Pl ParamX_P3) =>
-                       "lesen";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresSubj ParamX_Sg ParamX_P1) =>
-                       "lese";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresSubj ParamX_Sg ParamX_P2) =>
-                       "lesest";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresSubj ParamX_Sg ParamX_P3) =>
-                       "lese";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresSubj ParamX_Pl ParamX_P1) =>
-                       "lesen";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresSubj ParamX_Pl ParamX_P2) =>
-                       "leset";
-                     ResGer_VFin Prelude_True
-                                 (ResGer_VPresSubj ParamX_Pl ParamX_P3) =>
-                       "lesen";
-                     ResGer_VImper ParamX_Sg => "les";
-                     ResGer_VImper ParamX_Pl => "lest";
-                     ResGer_VPresPart ResGer_APred => "lesend";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Nom) =>
-                       "lesender";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Acc) =>
-                       "lesenden";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Dat) =>
-                       "lesendem";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Gen) =>
-                       "lesenden";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Nom) =>
-                       "lesende";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Acc) =>
-                       "lesende";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Dat) =>
-                       "lesender";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Gen) =>
-                       "lesender";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Nom) =>
-                       "lesendes";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Acc) =>
-                       "lesendes";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Dat) =>
-                       "lesendem";
-                     ResGer_VPresPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Gen) =>
-                       "lesenden";
-                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
-                       "lesende";
-                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
-                       "lesende";
-                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
-                       "lesenden";
-                     ResGer_VPresPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
-                       "lesender";
-                     ResGer_VPastPart ResGer_APred => "gelesen";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Nom) =>
-                       "gelesener";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Acc) =>
-                       "gelesenen";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Dat) =>
-                       "gelesenem";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Masc)
-                                                   ResGer_Gen) =>
-                       "gelesenen";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Nom) =>
-                       "gelesene";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Acc) =>
-                       "gelesene";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Dat) =>
-                       "gelesener";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Fem)
-                                                   ResGer_Gen) =>
-                       "gelesener";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Nom) =>
-                       "gelesenes";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Acc) =>
-                       "gelesenes";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Dat) =>
-                       "gelesenem";
-                     ResGer_VPastPart (ResGer_AMod (ResGer_GSg ResGer_Neutr)
-                                                   ResGer_Gen) =>
-                       "gelesenen";
-                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Nom) =>
-                       "gelesene";
-                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Acc) =>
-                       "gelesene";
-                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Dat) =>
-                       "gelesenen";
-                     ResGer_VPastPart (ResGer_AMod ResGer_GPl ResGer_Gen) =>
-                       "gelesener"};
-            aux = ResGer_VHaben; particle = ""; prefix = "";
-            vtype = ResGer_VAct};
-         a1 = ""; a2 = ""; adj = ""; ext = "";
-         inf = {s = ""; ctrl = ResGer_NoC; isAux = Prelude_True}; infExt = "";
-         isAux = Prelude_False;
-         nn =
-           table {ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P1 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P2 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P3 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P1 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P2 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Masc ParamX_Pl ParamX_P3 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P1 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P2 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Fem ParamX_Sg ParamX_P3 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P1 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P2 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Fem ParamX_Pl ParamX_P3 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P1 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P2 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Neutr ParamX_Sg ParamX_P3 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P1 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P2 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
-                  ResGer_Ag ResGer_Neutr ParamX_Pl ParamX_P3 =>
-                    {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""}};
-         subjc =
-           {s = ""; c = ResGer_NPC ResGer_Nom; isPrep = Prelude_False;
-            s2 = ""}};
-}

testsuite/canonical/grammars/Foods.gf

@@ -1,16 +0,0 @@
--- (c) 2009 Aarne Ranta under LGPL
-
-abstract Foods = {
-  flags startcat = Comment ;
-  cat
-    Comment ; Item ; Kind ; Quality ;
-  fun
-    -- Pred : Item -> Quality -> Comment ;
-    -- This, That, These, Those : Kind -> Item ;
-    -- Mod : Quality -> Kind -> Kind ;
-    -- Wine, Cheese, Fish, Pizza : Kind ;
-    -- Very : Quality -> Quality ;
-    -- Fresh, Warm, Italian,
-    --   Expensive, Delicious, Boring : Quality ;
-    Expensive: Quality;
-}

testsuite/canonical/grammars/Phrasebook.gf

@@ -1,9 +0,0 @@
-abstract Phrasebook = {
-
-cat PlaceKind ;
-fun Airport : PlaceKind ;
-
-cat VerbPhrase ;
-fun VRead : VerbPhrase ;
-
-}

testsuite/canonical/grammars/PhrasebookBul.gf

@@ -1,31 +0,0 @@
---# -path=.:present
-
-concrete PhrasebookBul of Phrasebook =
-  open
-    SyntaxBul,
-    (R = ResBul),
-    ParadigmsBul,
-    Prelude in {
-
-  lincat
-    PlaceKind = CNPlace ;
-
-  oper
-    CNPlace : Type = {name : CN ; at : Prep ; to : Prep; isPl : Bool} ;
-
-    mkPlace : N -> Prep -> {name : CN ; at : Prep ; to : Prep; isPl : Bool} = \n,p ->
-      mkCNPlace (mkCN n) p to_Prep ;
-
-    mkCNPlace : CN -> Prep -> Prep -> CNPlace = \p,i,t -> {
-      name = p ;
-      at = i ;
-      to = t ;
-      isPl = False
-      } ;
-
-    na_Prep = mkPrep "на" R.Acc ;
-
-  lin
-    Airport = mkPlace (mkN066 "летище") na_Prep ;
-
-}

testsuite/canonical/grammars/PhrasebookGer.gf

@@ -1,14 +0,0 @@
---# -path=.:present
-
-concrete PhrasebookGer of Phrasebook =
-  open
-    SyntaxGer,
-    LexiconGer in {
-
-  lincat
-    VerbPhrase  = VP ;
-
-  lin
-    VRead = mkVP <lin V read_V2 : V> ;
-
-}

testsuite/canonical/run-on-grammar.sh

@@ -1,36 +0,0 @@
-#!/usr/bin/env sh
-
-# For a given grammar, compile into canonical format,
-# then ensure that the canonical format itself is compilable.
-
-if [ $# -lt 1 ]; then
-  echo "Please specify concrete modules to test with, e.g.:"
-  echo "./run-on-grammar.sh ../../../gf-contrib/foods/FoodsEng.gf  ../../../gf-contrib/foods/FoodsFin.gf"
-  exit 2
-fi
-
-FAILURES=0
-
-for CNC_PATH in "$@"; do
-  CNC_FILE=$(basename "$CNC_PATH")
-  stack run -- --batch --output-format=canonical_gf "$CNC_PATH"
-  if [ $? -ne 0 ]; then
-    echo "Failed to compile into canonical"
-    FAILURES=$((FAILURES+1))
-    continue
-  fi
-
-  stack run -- --batch "canonical/$CNC_FILE"
-  if [ $? -ne 0 ]; then
-    echo "Failed to compile canonical"
-    FAILURES=$((FAILURES+1))
-  fi
-done
-
-# Summary
-if [ $FAILURES -ne 0 ]; then
-  echo "Failures: $FAILURES"
-  exit 1
-else
-  echo "All tests passed"
-fi

testsuite/canonical/run.sh

@@ -1,54 +0,0 @@
-#!/usr/bin/env sh
-
-FAILURES=0
-
-# https://github.com/GrammaticalFramework/gf-core/issues/100
-stack run -- --batch --output-format=canonical_gf grammars/PhrasebookBul.gf
-stack run -- --batch canonical/PhrasebookBul.gf
-if [ $? -ne 0 ]; then
-  echo "Canonical grammar doesn't compile: FAIL"
-  FAILURES=$((FAILURES+1))
-else
-  # echo "Canonical grammar compiles: OK"
-  diff canonical/PhrasebookBul.gf gold/PhrasebookBul.gf
-  if [ $? -ne 0 ]; then
-    echo "Canonical grammar doesn't match gold version: FAIL"
-    FAILURES=$((FAILURES+1))
-  else
-    echo "Canonical grammar matches gold version: OK"
-  fi
-fi
-
-echo ""
-
-# https://github.com/GrammaticalFramework/gf-core/issues/101
-stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf
-diff canonical/PhrasebookGer.gf gold/PhrasebookGer.gf
-if [ $? -ne 0 ]; then
-  echo "Canonical grammar doesn't match gold version: FAIL"
-  FAILURES=$((FAILURES+1))
-else
-  echo "Canonical grammar matches gold version: OK"
-fi
-
-echo ""
-
-# https://github.com/GrammaticalFramework/gf-core/issues/102
-stack run -- --batch --output-format=canonical_gf grammars/FoodsFin.gf
-diff canonical/FoodsFin.gf gold/FoodsFin.gf
-if [ $? -ne 0 ]; then
-  echo "Canonical grammar doesn't match gold version: FAIL"
-  FAILURES=$((FAILURES+1))
-else
-  echo "Canonical grammar matches gold version: OK"
-fi
-
-echo ""
-
-# Summary
-if [ $FAILURES -ne 0 ]; then
-  echo "Failures: $FAILURES"
-  exit 1
-else
-  echo "All tests passed"
-fi

testsuite/compiler/check/lincat-types/Predef.gf

@@ -1,48 +0,0 @@
---1 Predefined functions for concrete syntax
-
--- The definitions of these constants are hard-coded in GF, and defined
--- in Predef.hs (gf-core/src/compiler/GF/Compile/Compute/Predef.hs).
--- Applying them to run-time variables leads to compiler errors that are
--- often only detected at the code generation time.
-
-resource Predef = {
-
--- This type of booleans is for internal use only.
-
-  param PBool = PTrue | PFalse ;
-
-  oper Error : Type = variants {} ;          -- the empty type
-  oper Float : Type = variants {} ;          -- the type of floats
-  oper Int   : Type = variants {} ;          -- the type of integers
-  oper Ints  : Int -> PType = variants {} ;  -- the type of integers from 0 to n
-
-  oper error  : Str        -> Error    = variants {} ; -- forms error message
-  oper length : Tok ->        Int      = variants {} ; -- length of string
-  oper drop   : Int -> Tok -> Tok      = variants {} ; -- drop prefix of length
-  oper take   : Int -> Tok -> Tok      = variants {} ; -- take prefix of length
-  oper tk     : Int -> Tok -> Tok      = variants {} ; -- drop suffix of length
-  oper dp     : Int -> Tok -> Tok      = variants {} ; -- take suffix of length
-  oper eqInt  : Int -> Int -> PBool    = variants {} ; -- test if equal integers
-  oper lessInt: Int -> Int -> PBool    = variants {} ; -- test order of integers
-  oper plus   : Int -> Int -> Int      = variants {} ; -- add integers
-  oper eqStr  : Tok -> Tok -> PBool    = variants {} ; -- test if equal strings
-  oper occur  : Tok -> Tok -> PBool    = variants {} ; -- test if occurs as substring
-  oper occurs : Tok -> Tok -> PBool    = variants {} ; -- test if any char occurs
-  oper isUpper : Tok       -> PBool    = variants {} ; -- test if all chars are upper-case
-  oper toUpper : Tok       -> Tok      = variants {} ; -- map all chars to upper case
-  oper toLower : Tok       -> Tok      = variants {} ; -- map all chars to lower case
-  oper show   : (P : Type) -> P -> Tok = variants {} ; -- convert param to string
-  oper read   : (P : Type) -> Tok -> P = variants {} ; -- convert string to param
-  oper eqVal  : (P : Type) -> P -> P -> PBool = variants {} ; -- test if equal values
-  oper toStr  : (L : Type) -> L -> Str = variants {} ; -- find the "first" string
-  oper mapStr : (L : Type) -> (Str -> Str) -> L -> L = variants {} ; 
-               -- map all strings in a data structure; experimental ---
-
-  oper nonExist : Str = variants {} ;    -- a placeholder for non-existant morphological forms
-  oper BIND : Str = variants {} ;        -- a token for gluing
-  oper SOFT_BIND : Str = variants {} ;   -- a token for soft gluing
-  oper SOFT_SPACE : Str = variants {} ;  -- a token for soft space
-  oper CAPIT : Str = variants {} ;       -- a token for capitalization
-  oper ALL_CAPIT : Str = variants {} ;   -- a token for capitalization of abreviations
-
-} ;

testsuite/compiler/check/lincat-types/test.gfs.gold

@@ -1,9 +1,7 @@
 
 
-testsuite/compiler/check/lincat-types/TestCnc.gf:
-   testsuite/compiler/check/lincat-types/TestCnc.gf:3:
-     Happened in linearization type of S
-       type of PTrue
-      expected: Type
-      inferred: Predef.PBool
-      
+testsuite/compiler/check/lincat-types/TestCnc.gf:3:
+  Happened in linearization type of S
+    type of PTrue
+   expected: Type
+   inferred: PBool

testsuite/compiler/check/lins/lins.gfs.gold

@@ -1,41 +1,39 @@
-abstract lins {
-  cat C Nat ;
-  cat Float ;
-  cat Int ;
-  cat Nat ;
-  cat String ;
-  fun test : C zero ;
-  fun zero : Nat ;
-}
-concrete linsCnc {
-  productions
-    C1 -> F4[]
-  lindefs
-    C0 -> F0[CVar]
-    C1 -> F2[CVar]
-  linrefs
-    CVar -> F1[C0]
-    CVar -> F3[C1]
-  lin
-    F0 := (S2) ['lindef C']
-    F1 := (S1) ['lindef C']
-    F2 := () ['lindef Nat']
-    F3 := (S0) ['lindef Nat']
-    F4 := () [zero]
-  sequences
-    S0 :=
-    S1 := <0,0>
-    S2 := {0,0}
-  categories
-    C := range  [C0 .. C0]
-         labels ["s"]
-    Float := range  [CFloat .. CFloat]
-             labels ["s"]
-    Int := range  [CInt .. CInt]
-           labels ["s"]
-    Nat := range  [C1 .. C1]
-           labels []
-    String := range  [CString .. CString]
-              labels ["s"]
-  printnames
-}
+checking module linsCnc
+   Warning: no linearization type for C, inserting default {s : Str}
+   Warning: no linearization of test
+abstract lins {
+  cat C Nat ;
+  cat Float ;
+  cat Int ;
+  cat Nat ;
+  cat String ;
+  fun test : C zero ;
+  fun zero : Nat ;
+}
+concrete linsCnc {
+  productions
+    C1 -> F2[]
+  lindefs
+    C0 -> F0
+    C1 -> F1
+  lin
+    F0 := (S0) [lindef C]
+    F1 := () [lindef Nat]
+    F2 := () [zero]
+  sequences
+    S0 := {0,0}
+  categories
+    C := range  [C0 .. C0]
+         labels ["s"]
+    Float := range  [CFloat .. CFloat]
+             labels ["s"]
+    Int := range  [CInt .. CInt]
+           labels ["s"]
+    Nat := range  [C1 .. C1]
+           labels []
+    String := range  [CString .. CString]
+              labels ["s"]
+    __gfVar := range  [CVar .. CVar]
+               labels [""]
+  printnames
+}

testsuite/compiler/check/oper-definition/test.gfs.gold

@@ -1,6 +1,5 @@
 
 
-testsuite/compiler/check/oper-definition/Res.gf:
-   testsuite/compiler/check/oper-definition/Res.gf:3:
-     Happened in operation my_oper
-      No definition given to the operation
+testsuite/compiler/check/oper-definition/Res.gf:3:
+  Happened in operation my_oper
+   No definition given to the operation

testsuite/compiler/check/strMatch/Prelude.gf

@@ -1,161 +0,0 @@
---1 The GF Prelude
-
--- This file defines some prelude facilities usable in all grammars.
-
-resource Prelude = Predef[nonExist, BIND, SOFT_BIND, SOFT_SPACE, CAPIT, ALL_CAPIT] ** open (Predef=Predef) in {
-
-oper
-
---2 Strings, records, and tables
-
-  SS  : Type = {s : Str} ;
-  ss  : Str -> SS = \s -> {s = s} ;
-  ss2 : (_,_ : Str) -> SS = \x,y -> ss (x ++ y) ;
-  ss3 : (_,_ ,_: Str) -> SS = \x,y,z -> ss (x ++ y ++ z) ;
-
-  cc2 : (_,_ : SS) -> SS = \x,y -> ss (x.s ++ y.s) ;
-  cc3 : (_,_,_ : SS) -> SS = \x,y,z -> ss (x.s ++ y.s ++ z.s) ;
-
-  SS1 : PType -> Type = \P -> {s : P => Str} ;
-  ss1 : (A : PType) -> Str -> SS1 A = \A,s -> {s = table {_ => s}} ;
-
-  SP1 : Type -> Type = \P -> {s : Str ; p : P} ;
-  sp1 : (A : Type) -> Str -> A -> SP1 A = \_,s,a -> {s = s ; p = a} ;
-
-  constTable : (A : PType) -> (B : Type) -> B -> A => B = \u,v,b -> \\_ => b ;
-  constStr   : (A : PType) -> Str -> A => Str = \A -> constTable A Str ;
-
--- Discontinuous constituents.
-
-  SD2 : Type = {s1,s2 : Str} ;
-  sd2 : (_,_ : Str) -> SD2 = \x,y -> {s1 = x ; s2 = y} ;
-
-
---2 Optional elements
-
--- Optional string with preference on the string vs. empty.
- 
-  optStr : Str -> Str = \s -> variants {s ; []} ;
-  strOpt : Str -> Str = \s -> variants {[] ; s} ;
-
--- Free order between two strings.
-
-  bothWays : Str -> Str -> Str = \x,y -> variants {x ++ y ; y ++ x} ;
-
--- Parametric order between two strings.
-
-  preOrPost : Bool -> Str -> Str -> Str = \pr,x,y -> 
-    if_then_Str pr (x ++ y) (y ++ x) ;
-
---2 Infixes. prefixes, and postfixes
-
--- Fixes with precedences are defined in [Precedence Precedence.html].
-
-  infixSS   : Str  -> SS -> SS -> SS = \f,x,y -> ss (x.s ++ f ++ y.s) ;
-  prefixSS  : Str        -> SS -> SS = \f,x   -> ss (f ++ x.s) ;
-  postfixSS : Str        -> SS -> SS = \f,x   -> ss (x.s ++ f) ;
-  embedSS   : Str -> Str -> SS -> SS = \f,g,x -> ss (f ++ x.s ++ g) ;
-
-
---2 Booleans
-
- param Bool = False | True ;
-
-oper
-  if_then_else : (A : Type) -> Bool -> A -> A -> A = \_,c,d,e -> 
-    case c of {
-      True => d ;  ---- should not need to qualify
-      False => e
-     } ;
-
-  andB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a b False ;
-  orB  : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a True b ;
-  notB : Bool         -> Bool = \a   -> if_then_else Bool a False True ;
-
-  if_then_Str : Bool -> Str -> Str -> Str = if_then_else Str ;
-
-  onlyIf : Bool -> Str -> Str = \b,s -> case b of {
-    True => s ;
-    _ => nonExist
-    } ;
-
--- Interface to internal booleans
-
-  pbool2bool : Predef.PBool -> Bool = \b -> case b of {
-    Predef.PFalse => False ; Predef.PTrue => True
-    } ;
-
-  init : Tok -> Tok = Predef.tk 1 ;
-  last : Tok -> Tok = Predef.dp 1 ;
-
---2 High-level acces to Predef operations
-
-  isNil : Tok -> Bool = \b -> pbool2bool (Predef.eqStr [] b) ;
-
-  ifTok : (A : Type) -> Tok -> Tok -> A -> A -> A = \A,t,u,a,b -> 
-    case Predef.eqStr t u of {Predef.PTrue => a ; Predef.PFalse => b} ;
-
---2 Lexer-related operations
-
--- Bind together two tokens in some lexers, either obligatorily or optionally
-
-  oper 
-    glue : Str -> Str -> Str = \x,y -> x ++ BIND ++ y ;
-    glueOpt : Str -> Str -> Str = \x,y -> variants {glue x y ; x ++ y} ;
-    noglueOpt : Str -> Str -> Str = \x,y -> variants {x ++ y ; glue x y} ;
-
--- Force capitalization of next word in some unlexers
-
-    capitalize : Str -> Str = \s -> CAPIT ++ s ;
-
--- These should be hidden, and never changed since they are hardcoded in (un)lexers
-
-    PARA : Str = "&-" ;
-
--- Embed between commas, where the latter one disappears in front of other punctuation
-
-    embedInCommas : Str -> Str = \s -> bindComma ++ s ++ endComma ;
-    endComma : Str = pre {"," | "." => []; "" => bindComma ; _ => []} ;
-
-    bindComma : Str = SOFT_BIND ++ "," ;
-    optComma : Str = bindComma | [] ;
-    optCommaSS : SS -> SS = \s -> ss (s.s ++ optComma) ;
-
---2 Miscellaneous
-
--- Identity function
-
-  id : (A : Type) -> A -> A = \_,a -> a ;
-
--- Parentheses
-
-  paren : Str -> Str = \s -> "(" ++ s ++ ")" ;
-  parenss : SS -> SS = \s -> ss (paren s.s) ;
-
--- Zero, one, two, or more (elements in a list etc)
-
-param
-  ENumber = E0 | E1 | E2 | Emore ;
-
-oper
-  eNext : ENumber -> ENumber = \e -> case e of {
-    E0 => E1 ; E1 => E2 ; _ => Emore} ;
-
--- convert initial to upper/lower
-
-  toUpperFirst : Str -> Str = \s -> case s of {
-    x@? + xs => Predef.toUpper x + xs ;
-    _ => s
-    } ;
-
-  toLowerFirst : Str -> Str = \s -> case s of {
-    x@? + xs => Predef.toLower x + xs ;
-    _ => s
-    } ;
-
--- handling errors caused by temporarily missing definitions
-
-  notYet : Str -> Predef.Error = \s ->
-    Predef.error ("NOT YET IMPLEMENTED:" ++ s) ;
-
-}

testsuite/compiler/check/strMatch/strMatch.gfs.gold

@@ -1 +0,0 @@
-

testsuite/compiler/typecheck/abstract/LetInDefAbs.gfs.gold

@@ -1,15 +0,0 @@
-fun f : Int -> Int ;
-def f n = ? ;
-000 CHECK_ARGS  1
-    ALLOC       2
-    PUT_CLOSURE 001
-    SET_PAD
-    TUCK        hp(0) 1
-    EVAL        f tail(0)
-001 ALLOC       2
-    PUT_LIT     0
-    PUSH_FRAME
-    PUSH        hp(0)
-    EVAL        f update
-Probability: 1.0
-

testsuite/compiler/typecheck/abstract/LetInTypesAbs.gfs.gold

@@ -1,3 +1 @@
-fun f : (Int -> Int) -> Int -> Int ;
-Probability: 1.0
-
+fun f : (Int -> Int) -> Int -> Int

testsuite/compiler/typecheck/abstract/LitAbs.gf

@@ -5,7 +5,7 @@ cat CStr String ;
     CFloat Float ;
 
 data empty : CStr "" ;
-    -- null  : CStr [] ; -- Commented out by IL 06/2021: causes parse error
+     null  : CStr [] ;
      other : CStr "other" ;
 
 data zero : CInt 0 ;

testsuite/compiler/typecheck/abstract/LitAbs.gfs

@@ -1,4 +1,5 @@
 i -src testsuite/compiler/typecheck/abstract/LitAbs.gf
+ai null
 ai empty
 ai other
 ai zero

testsuite/compiler/typecheck/abstract/LitAbs.gfs.gold

@@ -1,12 +1,5 @@
-data empty : CStr "" ;
-Probability: 0.5
-
-data other : CStr "other" ;
-Probability: 0.5
-
-data zero : CInt 0 ;
-Probability: 1.0
-
-data pi : CFloat 3.14 ;
-Probability: 1.0
-
+data null : CStr ""
+
+data empty : CStr ""
+
+data other : CStr "other"

testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs

@@ -1,5 +1,2 @@
 i -src testsuite/compiler/typecheck/abstract/PolyTypes.gf
-ai f
-
-i -src testsuite/compiler/typecheck/abstract/RecTypes.gf
-ai f
+i -src testsuite/compiler/typecheck/abstract/RecTypes.gf

testsuite/compiler/typecheck/abstract/test_A.gfs.gold

@@ -1,6 +1,5 @@
 
 
-testsuite/compiler/typecheck/abstract/A.gf:
-   testsuite/compiler/typecheck/abstract/A.gf:4:
-     Happened in the category B
-      Prod expected for function A instead of Type
+testsuite/compiler/typecheck/abstract/A.gf:4:
+  Happened in the category B
+   Prod expected for function A instead of Type

testsuite/compiler/typecheck/abstract/test_B.gfs.gold

@@ -1,6 +1,5 @@
 
 
-testsuite/compiler/typecheck/abstract/B.gf:
-   testsuite/compiler/typecheck/abstract/B.gf:5:
-     Happened in the type of function f
-      Prod expected for function S instead of Type
+testsuite/compiler/typecheck/abstract/B.gf:5:
+  Happened in the type of function f
+   Prod expected for function S instead of Type

testsuite/compiler/typecheck/abstract/test_C.gfs.gold

@@ -1,6 +1,5 @@
 
 
-testsuite/compiler/typecheck/abstract/C.gf:
-   testsuite/compiler/typecheck/abstract/C.gf:6:
-     Happened in the definition of function f
-      {Int <> S}
+testsuite/compiler/typecheck/abstract/C.gf:6:
+  Happened in the definition of function f
+   {Int <> S}

testsuite/compiler/typecheck/concrete/test_A.gfs.gold

@@ -1,9 +1,5 @@
 
 
-testsuite/compiler/typecheck/concrete/A.gf:
-   testsuite/compiler/typecheck/concrete/A.gf:5:
-     Happened in operation silly
-      A function type is expected for a_Det instead of type Str
-      
-   ** Maybe you gave too many arguments to a_Det 
-
+testsuite/compiler/typecheck/concrete/A.gf:5:
+  Happened in operation silly
+   A function type is expected for a_Det instead of type Str

testsuite/libraries/exx-resource.gfs

@@ -0,0 +1,226 @@
+se utf8
+i alltenses/LangEng.gfo
+i alltenses/LangSwe.gfo
+i alltenses/LangBul.gfo
+-- Adjective
+
+l -treebank PositA warm_A
+l -treebank ComparA warm_A (UsePron i_Pron)
+l -treebank ComplA2 married_A2 (UsePron she_Pron)
+l -treebank ComplA2 married_A2 (DetNP (DetQuant (PossPron she_Pron) NumPl))
+l -treebank ComplA2 married_A2 (DetNP (DetQuant (PossPron she_Pron) NumSg))
+l -treebank ReflA2 married_A2
+l -treebank PositA (UseA2 married_A2)
+l -treebank SentAP (PositA good_A) (EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseComp (CompAdv here_Adv)))))
+l -treebank AdAP very_AdA (PositA warm_A)
+
+
+-- Adverb
+
+l -treebank PositAdvAdj warm_A
+l -treebank PrepNP in_Prep (DetCN (DetQuant DefArt NumSg) (UseN house_N))
+l -treebank ComparAdvAdj more_CAdv warm_A (UsePN john_PN)
+l -treebank ComparAdvAdjS more_CAdv warm_A (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV run_V)))
+l -treebank SubjS when_Subj (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V)))
+l -treebank AdNum (AdnCAdv more_CAdv) (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))
+
+
+-- Conjunction
+
+l -treebank ConjS and_Conj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV walk_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V))))
+l -treebank ConjAP and_Conj (BaseAP (PositA cold_A) (PositA warm_A))
+l -treebank ConjNP or_Conj (BaseNP (UsePron she_Pron) (UsePron we_Pron))
+l -treebank ConjAdv or_Conj (BaseAdv here_Adv there_Adv)
+l -treebank ConjS either7or_DConj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron he_Pron) (UseV walk_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V))))
+l -treebank ConjAP both7and_DConj (BaseAP (PositA warm_A) (PositA cold_A))
+l -treebank ConjNP either7or_DConj (BaseNP (UsePron he_Pron) (UsePron she_Pron))
+l -treebank ConjAdv both7and_DConj (BaseAdv here_Adv there_Adv)
+
+-- Idiom
+
+l -treebank ImpersCl (UseComp (CompAP (PositA hot_A)))
+l -treebank GenericCl (UseV sleep_V)
+l -treebank CleftNP (UsePron i_Pron) (UseRCl (TTAnt TPast ASimul) PPos (RelVP IdRP (ComplSlash (SlashV2a do_V2) (UsePron it_Pron))))
+l -treebank CleftAdv here_Adv (UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V)))
+l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (UseN house_N))
+l -treebank ExistIP (IdetCN (IdetQuant which_IQuant NumPl) (UseN house_N))
+l -treebank PredVP (UsePron i_Pron) (ProgrVP (UseV sleep_V))
+l -treebank ImpPl1 (UseV go_V)
+
+-- Noun
+
+l -treebank DetCN (DetQuant DefArt NumSg) (UseN man_N)
+l -treebank UsePN john_PN
+l -treebank UsePron he_Pron
+l -treebank PredetNP only_Predet (DetCN (DetQuant DefArt NumSg) (UseN man_N))
+l -treebank PPartNP (DetCN (DetQuant DefArt NumSg) (UseN man_N)) see_V2
+l -treebank AdvNP (UsePN paris_PN) today_Adv
+l -treebank RelNP (UsePN paris_PN) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (UseComp (CompAdv here_Adv))))
+l -treebank DetNP (DetQuant this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))))
+l -treebank DetCN (DetQuantOrd this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))) (OrdSuperl good_A)) (UseN man_N)
+l -treebank DetCN (DetQuant this_Quant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN man_N)
+l -treebank DetCN (DetQuant this_Quant NumPl) (UseN man_N)
+l -treebank DetCN (DetQuant this_Quant NumSg) (UseN man_N)
+l -treebank NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))
+l -treebank NumCard (NumDigits (IIDig D_5 (IDig D_1)))
+l -treebank NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot1plus n5 pot01)))))
+l -treebank NumCard (AdNum almost_AdN (NumDigits (IIDig D_5 (IDig D_1))))
+l -treebank OrdDigits (IIDig D_5 (IDig D_1))
+l -treebank OrdNumeral (num (pot2as3 (pot1as2 (pot1plus n5 pot01))))
+l -treebank OrdSuperl warm_A
+l -treebank DetCN (DetQuantOrd DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))) (OrdSuperl good_A)) (UseN man_N)
+l -treebank DetCN (DetQuant DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN man_N)
+l -treebank DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 pot01))))))) (UseN man_N)
+l -treebank DetCN (DetQuant DefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 pot01))))))) (UseN man_N)
+l -treebank DetCN (DetQuant DefArt NumSg) (UseN man_N)
+l -treebank DetCN (DetQuant DefArt NumPl) (UseN man_N)
+l -treebank MassNP (UseN beer_N)
+l -treebank DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN house_N)
+l -treebank UseN house_N
+l -treebank ComplN2 mother_N2 (DetCN (DetQuant DefArt NumSg) (UseN king_N))
+l -treebank ComplN2 (ComplN3 distance_N3 (DetCN (DetQuant this_Quant NumSg) (UseN city_N))) (UsePN paris_PN)
+l -treebank UseN2 mother_N2
+l -treebank ComplN2 (Use2N3 distance_N3) (DetCN (DetQuant this_Quant NumSg) (UseN city_N))
+l -treebank ComplN2 (Use3N3 distance_N3) (UsePN paris_PN)
+l -treebank UseN2 (Use2N3 distance_N3)
+l -treebank AdjCN (PositA big_A) (UseN house_N)
+l -treebank RelCN (UseN house_N) (UseRCl (TTAnt TPast ASimul) PPos (RelSlash IdRP (SlashVP (UsePN john_PN) (SlashV2a buy_V2))))
+l -treebank AdvCN (UseN house_N) (PrepNP on_Prep (DetCN (DetQuant DefArt NumSg) (UseN hill_N)))
+l -treebank SentCN (UseN question_N) (EmbedQS (UseQCl (TTAnt TPres ASimul) PPos (QuestIAdv where_IAdv (PredVP (UsePron she_Pron) (UseV sleep_V)))))
+l -treebank DetCN (DetQuant DefArt NumSg) (ApposCN (UseN city_N) (UsePN paris_PN))
+l -treebank DetCN (DetQuant (PossPron i_Pron) NumSg) (ApposCN (UseN friend_N) (UsePN john_PN))
+
+-- Numeral
+
+l -treebank num (pot2as3 (pot1as2 (pot0as1 (pot0 n6))))
+l -treebank num (pot2as3 (pot1as2 (pot0as1 pot01)))
+l -treebank num (pot2as3 (pot1as2 (pot1 n6)))
+l -treebank num (pot2as3 (pot1as2 pot110))
+l -treebank num (pot2as3 (pot1as2 pot111))
+l -treebank num (pot2as3 (pot1as2 (pot1to19 n6)))
+l -treebank num (pot2as3 (pot1as2 (pot1 n6)))
+l -treebank num (pot2as3 (pot1as2 (pot1plus n6 (pot0 n5))))
+l -treebank num (pot2as3 (pot2 (pot0 n4)))
+l -treebank num (pot2as3 (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7))))
+l -treebank num (pot3 (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7))))
+l -treebank num (pot3plus (pot2plus (pot0 n4) (pot1plus n6 (pot0 n7))) (pot1as2 (pot1plus n8 (pot0 n9))))
+l -treebank IDig D_8
+l -treebank IIDig D_8 (IIDig D_0 (IIDig D_0 (IIDig D_1 (IIDig D_7 (IIDig D_8 (IDig D_9))))))
+
+
+-- Phrase
+
+l -treebank PhrUtt but_PConj (UttImpSg PPos (ImpVP (AdvVP (UseV come_V) here_Adv))) (VocNP (DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN friend_N)))
+l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePN john_PN) (UseV walk_V)))) NoVoc
+l -treebank UttQS (UseQCl (TTAnt TPres ASimul) PPos (QuestCl (PredVP (UsePron it_Pron) (UseComp (CompAP (PositA good_A))))))
+l -treebank UttImpSg PNeg (ImpVP (ReflVP (SlashV2a love_V2)))
+l -treebank UttImpPl PNeg (ImpVP (ReflVP (SlashV2a love_V2)))
+l -treebank UttImpPol PNeg (ImpVP (UseV sleep_V))
+l -treebank UttIP whoPl_IP
+l -treebank UttIP whoSg_IP
+l -treebank UttIAdv why_IAdv
+l -treebank UttNP (DetCN (DetQuant this_Quant NumSg) (UseN man_N))
+l -treebank UttAdv here_Adv
+l -treebank UttVP (UseV sleep_V)
+l -treebank VocNP (DetCN (DetQuant (PossPron i_Pron) NumSg) (UseN friend_N))
+
+
+-- Question
+
+l -treebank QuestCl (PredVP (UsePN john_PN) (UseV walk_V))
+l -treebank QuestVP whoSg_IP (UseV walk_V)
+l -treebank QuestSlash whoSg_IP (SlashVP (UsePN john_PN) (SlashV2a love_V2))
+l -treebank QuestIAdv why_IAdv (PredVP (UsePN john_PN) (UseV walk_V))
+l -treebank QuestIComp (CompIAdv where_IAdv) (UsePN john_PN)
+l -treebank IdetCN (IdetQuant which_IQuant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5)))))))) (UseN song_N)
+l -treebank IdetIP (IdetQuant which_IQuant (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n5))))))))
+l -treebank AdvIP whoSg_IP (PrepNP in_Prep (UsePN paris_PN))
+l -treebank IdetIP (IdetQuant which_IQuant NumSg)
+l -treebank PrepIP with_Prep whoSg_IP
+l -treebank QuestIComp (CompIAdv where_IAdv) (UsePron it_Pron)
+l -treebank QuestIComp (CompIP whoSg_IP) (UsePron it_Pron)
+
+
+-- Relative
+
+l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelCl (PredVP (UsePN john_PN) (ComplSlash (SlashV2a love_V2) (UsePron she_Pron)))))))
+l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (ComplSlash (SlashV2a love_V2) (UsePN john_PN))))))
+l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePN john_PN) (SlashV2a love_V2))))))
+l -treebank ExistNP (DetCN (DetQuant IndefArt NumSg) (RelCN (UseN woman_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash (FunRP possess_Prep (DetCN (DetQuant DefArt NumSg) (UseN2 mother_N2)) IdRP) (SlashVP (UsePN john_PN) (SlashV2a love_V2))))))
+
+-- Sentence
+
+l -treebank PredVP (UsePN john_PN) (UseV walk_V)
+l -treebank PredSCVP (EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV go_V)))) (UseComp (CompAP (PositA good_A)))
+l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron he_Pron) (SlashV2a see_V2))))
+l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (AdvSlash (SlashVP (UsePron he_Pron) (SlashV2a see_V2)) today_Adv)))
+l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashPrep (PredVP (UsePron he_Pron) (UseV walk_V)) with_Prep)))
+l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVS (UsePron she_Pron) say_VS (UseSlash (TTAnt TPres ASimul) PPos (SlashVP (UsePron he_Pron) (SlashV2a love_V2))))))
+l -treebank ImpVP (ReflVP (SlashV2a love_V2))
+l -treebank EmbedS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV go_V)))
+l -treebank EmbedQS (UseQCl (TTAnt TPres ASimul) PPos (QuestVP whoSg_IP (UseV go_V)))
+l -treebank EmbedVP (UseV go_V)
+l -treebank UseCl (TTAnt TCond AAnter) PNeg (PredVP (UsePN john_PN) (UseV walk_V))
+l -treebank UseQCl (TTAnt TCond AAnter) PNeg (QuestCl (PredVP (UsePN john_PN) (UseV walk_V)))
+l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TCond AAnter) PNeg (RelVP IdRP (UseV walk_V)))
+l -treebank RelCN (UseN girl_N) (UseRCl (TTAnt TCond AAnter) PNeg (RelSlash IdRP (SlashPrep (PredVP (UsePron i_Pron) (UseV walk_V)) with_Prep)))
+l -treebank RelS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV sleep_V))) (UseRCl (TTAnt TPres ASimul) PPos (RelVP IdRP (UseComp (CompAP (PositA good_A)))))
+
+
+-- Text
+
+l -treebank TEmpty
+l -treebank TFullStop (PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePN john_PN) (UseV walk_V)))) NoVoc) TEmpty
+l -treebank TQuestMark (PhrUtt NoPConj (UttQS (UseQCl (TTAnt TPres ASimul) PPos (QuestCl (PredVP (UsePron they_Pron) (UseComp (CompAdv here_Adv)))))) NoVoc) TEmpty
+l -treebank TExclMark (PhrUtt NoPConj (ImpPl1 (UseV go_V)) NoVoc) TEmpty
+
+-- Verb
+
+l -treebank PredVP (UsePron i_Pron) (UseV sleep_V)
+l -treebank PredVP (UsePron i_Pron) (ComplVV want_VV (UseV run_V))
+l -treebank PredVP (UsePron i_Pron) (ComplVS say_VS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron she_Pron) (UseV run_V))))
+l -treebank PredVP (UsePron i_Pron) (ComplVQ wonder_VQ (UseQCl (TTAnt TPres ASimul) PPos (QuestVP whoSg_IP (UseV run_V))))
+l -treebank PredVP (UsePron they_Pron) (ComplVA become_VA (PositA red_A))
+l -treebank PredVP (UsePron i_Pron) (ComplSlash (Slash3V3 give_V3 (UsePron he_Pron)) (UsePron it_Pron))
+l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2V beg_V2V (UseV go_V)) (UsePron she_Pron))
+l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2S answer_V2S (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron it_Pron) (UseComp (CompAP (PositA good_A)))))) (UsePron he_Pron))
+l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2Q ask_V2Q (UseQCl (TTAnt TPast ASimul) PPos (QuestVP whoSg_IP (UseV come_V)))) (UsePron he_Pron))
+l -treebank PredVP (UsePron i_Pron) (ComplSlash (SlashV2A paint_V2A (PositA red_A)) (UsePron it_Pron))
+l -treebank RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron i_Pron) (SlashVV want_VV (SlashV2a buy_V2)))))
+l -treebank RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron they_Pron) (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashV2a buy_V2)))))
+l -treebank PredVP (UsePron he_Pron) (ReflVP (SlashV2a love_V2))
+l -treebank PredVP (DetNP (DetQuant this_Quant NumSg)) (UseComp (CompAP (PositA warm_A)))
+l -treebank PredVP (UsePron we_Pron) (PassV2 love_V2)
+l -treebank PredVP (UsePron we_Pron) (AdvVP (UseV sleep_V) here_Adv)
+l -treebank PredVP (UsePron we_Pron) (AdVVP always_AdV (UseV sleep_V))
+l -treebank PredVP (UsePron we_Pron) (UseComp (CompAP (PositA small_A)))
+l -treebank PredVP (UsePron i_Pron) (UseComp (CompNP (DetCN (DetQuant IndefArt NumSg) (UseN man_N))))
+l -treebank PredVP (UsePron i_Pron) (UseComp (CompAdv here_Adv))
+
+
+
+-- Janna's and Krasimir's long examples
+
+l -treebank RelCN (UseN car_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron they_Pron) (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashVV want_VV (SlashV2A paint_V2A (PositA red_A)))))))
+l -treebank PhrUtt NoPConj (UttImpSg PPos (ImpVP (AdVVP always_AdV (ComplSlash (SlashV2a listen_V2) (DetCN (DetQuant DefArt NumSg) (UseN sea_N)))))) NoVoc
+l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (ExistNP (PredetNP only_Predet (DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot0as1 (pot0 n2)))))))) (AdvCN (RelCN (UseN woman_N) (UseRCl (TTAnt TCond ASimul) PPos (RelSlash IdRP (SlashPrep (PredVP (UsePron i_Pron) (ComplVV want_VV (PassV2 see_V2))) with_Prep)))) (PrepNP in_Prep (DetCN (DetQuant DefArt NumSg) (UseN rain_N))))))))) NoVoc
+l -treebank PhrUtt NoPConj (UttImpSg  PPos (ImpVP (ComplSlash (SlashV2A paint_V2A (ConjAP both7and_DConj (BaseAP (ComparA small_A (DetCN (DetQuant DefArt NumSg) (UseN sun_N))) (ComparA big_A (DetCN (DetQuant DefArt NumSg) (UseN moon_N)))))) (DetCN (DetQuant DefArt NumSg) (UseN earth_N))))) NoVoc
+l -treebank PhrUtt NoPConj (ImpPl1 (ComplVS hope_VS (ConjS either7or_DConj (BaseS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumSg) (ComplN2 father_N2 (DetCN (DetQuant DefArt NumSg) (UseN baby_N)))) (UseV run_V))) (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumSg) (UseN2 (Use2N3 distance_N3))) (UseComp (CompAP (PositA small_A))))))))) NoVoc
+l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN every_Det (UseN baby_N)) (UseComp (CompNP (ConjNP either7or_DConj (BaseNP (DetCN (DetQuant IndefArt NumSg) (UseN boy_N)) (DetCN (DetQuant IndefArt NumSg) (UseN girl_N))))))))) NoVoc
+l -treebank PhrUtt NoPConj (UttAdv (ConjAdv either7or_DConj (ConsAdv here7from_Adv (BaseAdv there_Adv everywhere_Adv)))) NoVoc
+l -treebank PhrUtt NoPConj (UttVP (PassV2 know_V2)) NoVoc
+l -treebank RelCN (UseN bird_N) (UseRCl (TTAnt TPres ASimul) PPos (RelSlash IdRP (SlashVP (UsePron i_Pron) (SlashVV want_VV (SlashV2A paint_V2A (PositA red_A))))))
+l -treebank UttImpSg PPos (ImpVP (ComplVV want_VV (ComplSlash (SlashV2a buy_V2) (UsePron it_Pron))))
+l -treebank UttImpSg PPos (ImpVP (ComplVV want_VV (ComplSlash (SlashV2A paint_V2A (PositA red_A)) (UsePron it_Pron))))
+l -treebank UttImpSg PPos (ImpVP (ComplSlash (SlashVV want_VV (SlashV2VNP beg_V2V (UsePron i_Pron) (SlashV2a buy_V2))) (UsePron it_Pron)))
+l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant DefArt NumPl) (UseN fruit_N)) (ReflVP (Slash3V3 sell_V3 (DetCN (DetQuant DefArt NumSg) (UseN road_N))))))) NoVoc
+l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2V beg_V2V (UseV live_V)))))) NoVoc
+l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2S answer_V2S (UseCl (TTAnt TPres ASimul) PPos (ImpersCl (ComplVV must_VV (ReflVP (SlashV2a understand_V2)))))))))) NoVoc
+l -treebank PhrUtt NoPConj (UttImpSg PPos (ImpVP (ReflVP (SlashV2Q ask_V2Q (UseQCl (TTAnt TPast ASimul) PPos (QuestVP whoSg_IP (UseV come_V))))))) NoVoc
+l -treebank PhrUtt NoPConj (UttS (UseCl (TTAnt TPast ASimul) PPos (PredVP (UsePron i_Pron) (ReflVP (SlashV2A paint_V2A (ComparA beautiful_A (UsePN john_PN))))))) NoVoc
+
+-- more long examples
+
+l -treebank UttS (UseCl (TTAnt TPres ASimul) PPos (PredVP (DetCN (DetQuant this_Quant NumSg) (UseN grammar_N)) (ComplSlash (SlashV2a speak_V2) (DetCN (DetQuant IndefArt (NumCard (NumNumeral (num (pot2as3 (pot1as2 (pot1to19 n2))))))) (UseN language_N)))))
+l -treebank UseCl (TTAnt TPast AAnter) PPos (PredVP (UsePron she_Pron) (ComplSlash (SlashV2a buy_V2) (DetCN (DetQuant IndefArt NumSg) (AdjCN (PositA red_A) (UseN house_N)))))
+

testsuite/lpgf/README.md

@@ -0,0 +1,239 @@
+# LPGF testsuite & benchmark
+
+## Test
+
+LPGF must be equivalent to PGF in terms of linearisation output.
+
+Possible exceptions:
+- No handling of variants (design choice)
+- Rendering of missing fucntions
+
+### Running
+
+```
+stack build --test --bench --no-run-tests --no-run-benchmarks
+stack test gf:test:lpgf # all LPGF tests
+stack test gf:test:lpgf --test-arguments="unittests/Params" # specific grammar
+stack test gf:test:lpgf --test-arguments="foods/Foods Fre Ger" # specific grammar and languages
+```
+
+```
+stack build --test --bench --no-run-tests --no-run-benchmarks && DEBUG=1 stack test gf:test:lpgf --test-arguments="foods/Foods Fre Ger"
+stack build --test --bench --no-run-tests --no-run-benchmarks && DEBUG=1 stack test gf:test:lpgf --test-arguments="phrasebook/Phrasebook Bul"
+```
+
+Set environment variable `DEBUG=1` to enable dumping of intermediate formats.
+
+## Benchmark
+
+Compare performance metrics between LPGF and PGF[2]. Note: correctness is not checked here.
+
+### Compilation
+
+Comparing PGF, LPGF along following criteria:
+
+- Time
+- Memory
+- Binary file size
+
+### Runtime (linearisation)
+
+Comparing PGF, PGF2, LPGF along following criteria:
+
+- Time
+- Memory
+
+### Running
+
+Run each command separately so that memory measurements are isolated.
+The `+RTS -T -RTS` is so that GHC can report its own memory usage.
+
+```
+stack build --test --bench --no-run-tests --no-run-benchmarks &&
+stack bench --benchmark-arguments "compile pgf  testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" &&
+stack bench --benchmark-arguments "compile lpgf testsuite/lpgf/foods/Foods*.gf +RTS -T -RTS" &&
+stack bench --benchmark-arguments "run pgf  Foods.pgf  testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" &&
+stack bench --benchmark-arguments "run pgf2 Foods.pgf  testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS" &&
+stack bench --benchmark-arguments "run lpgf Foods.lpgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS"
+```
+
+```
+stack build --test --bench --no-run-tests --no-run-benchmarks &&
+stack bench --benchmark-arguments "compile pgf  testsuite/lpgf/phrasebook/Phrasebook*.gf +RTS -T -RTS" &&
+stack bench --benchmark-arguments "compile lpgf testsuite/lpgf/phrasebook/Phrasebook*.gf +RTS -T -RTS" &&
+stack bench --benchmark-arguments "run pgf  Phrasebook.pgf  testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS" &&
+stack bench --benchmark-arguments "run pgf2 Phrasebook.pgf  testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS" &&
+stack bench --benchmark-arguments "run lpgf Phrasebook.lpgf testsuite/lpgf/phrasebook/Phrasebook-10000.trees +RTS -T -RTS"
+```
+
+## Profiling
+
+```
+stack bench --work-dir .stack-work-profile --profile --benchmark-arguments "compile lpgf testsuite/lpgf/phrasebook/PhrasebookFre.gf +RTS -T -p -h -RTS"
+```
+
+Produced files:
+- `lpgf-bench.prof` - total time and memory allocation (`-p`)
+- `lpgf-bench.hp` - heap profile (`-h`)
+
+```
+stack exec -- hp2ps -c lpgf-bench.hp && open lpgf-bench.ps
+```
+
+**Resources**
+
+- https://downloads.haskell.org/ghc/8.6.5/docs/html/users_guide/profiling.html
+- http://book.realworldhaskell.org/read/profiling-and-optimization.html
+- https://wiki.haskell.org/Performance
+
+# Notes on compilation
+
+## 1 (see unittests/Params4)
+
+**param defns**
+P = P1 | P2
+Q = Q1 | Q2
+R = RP P | RPQ P Q | R0
+X = XPQ P Q
+
+**translation**
+NB: tuples may be nested, but will be concatted at runtime
+
+P1        = <1>
+P2        = <2>
+
+Q1        = <1>
+Q2        = <2>
+
+R P1      = <1,1>
+R P2      = <1,2>
+RPQ P1 Q1 = <2,1,1>
+RPQ P1 Q2 = <2,1,2>
+RPQ P2 Q1 = <2,2,1>
+RPQ P2 Q2 = <2,2,2>
+R0        = <3>
+
+XPQ P1 Q1 = <1,1,1>
+XPQ P1 Q2 = <1,1,2>
+XPQ P2 Q1 = <1,2,1>
+XPQ P2 Q2 = <1,2,2>
+
+P => Str
+<"P1","P2">
+
+{p:P ; q:Q} => Str
+<<"P1;Q1","P1;Q2">,<"P2;Q1","P2;Q2">>
+
+{p=P2; q=Q1}
+<<2>,<1>>
+
+R => Str
+< <"RP P1","RP P2">,
+  < <"RPQ P1 Q1","RPQ P1 Q2">,
+    <"RPQ P2 Q1","RPQ P2 Q2"> >,
+ "R0"
+>
+
+X => Str
+<<<"XPQ P1 Q1","XPQ P1 Q2">,
+  <"XPQ P2 Q1","XPQ P2 Q2">>>
+
+{p=P2 ; r=R0}
+<<2>,<3>>
+
+{p=P2 ; r1=RP P1 ; r2=RPQ P1 Q2 ; r3=R0 }
+< <2>  ,  <1, 1> ,   <2,  1, 2> ,   <3>>
+
+## 2 (see unittests/Params5)
+
+**param defns**
+
+P = P1 | PQ Q
+Q = Q1 | QR R
+R = R1 | R2
+
+**translation**
+
+P1       = <1>
+PQ Q1    = <2,1>
+PQ QR R1 = <2,2,1>
+PQ QR R2 = <2,2,2>
+
+Q1       = <1>
+QR R1    = <2,1>
+QR R2    = <2,2>
+
+R1       = <1>
+R2       = <2>
+
+P => Str
+<"P1",<"PQ Q1",<"PQ (QR R1)","PQ (QR R2)">>>
+
+{q:Q ; p:P} => Str
+< <"Q1;P1",<"Q1;PQ Q1",<"Q1;PQ (QR R1)","Q1;PQ (QR R2)">>>,
+  <
+    <"QR R1;P1",<"QR R1;PQ Q1",<"QR R1;PQ (QR R1)","QR R1;PQ (QR R2)">>>,
+    <"QR R2;P1",<"QR R2;PQ Q1",<"QR R2;PQ (QR R1)","QR R2;PQ (QR R2)">>>
+  >
+>
+
+{q=Q1 ; p=P1}            = <<1>,<1>>
+{q=Q1 ; p=PQ Q1}         = <<1>,<2,1>>
+{q=Q1 ; p=PQ (QR R1)}    = <<1>,<2,2,1>>
+{q=Q1 ; p=PQ (QR R2)}    = <<1>,<2,2,2>>
+
+{q=QR R1 ; p=P1}         = <<2,1>,<1>>
+{q=QR R1 ; p=PQ Q1}      = <<2,1>,<2,1>>
+{q=QR R1 ; p=PQ (QR R1)} = <<2,1>,<2,2,1>>
+{q=QR R1 ; p=PQ (QR R2)} = <<2,1>,<2,2,2>>
+
+{q=QR R2 ; p=P1}         = <<2,2>,<1>>
+{q=QR R2 ; p=PQ Q1}      = <<2,2>,<2,1>>
+{q=QR R2 ; p=PQ (QR R1)} = <<2,2>,<2,2,1>>
+{q=QR R2 ; p=PQ (QR R2)} = <<2,2>,<2,2,2>>
+
+**NOTE**: GF will swap q and p in record, as part of record field sorting, resulting in the following:
+
+{p:P ; q:Q} => Str
+< <"P1;Q1", <"P1;QR R1","P1;QR R2">>,
+  < <"PQ Q1;Q1", <"PQ Q1;QR R1","PQ Q1;QR R2">>,
+    < <"PQ (QR R1);Q1", <"PQ (QR R1);QR R1","PQ (QR R1);QR R2">>,
+      <"PQ (QR R2);Q1", <"PQ (QR R2);QR R1","PQ (QR R2);QR R2">>
+    >
+  >
+>
+
+{p=P1 ; q=Q1}            = <<1>,<1>>
+{p=P1 ; q=QR R1}         = <<1>,<2,1>>
+{p=P1 ; q=QR R2}         = <<1>,<2,2>>
+
+{p=PQ Q1 ; q=Q1}         = <<2,1>,<1>>
+{p=PQ Q1 ; q=QR R1}      = <<2,1>,<2,1>>
+{p=PQ Q1 ; q=QR R2}      = <<2,1>,<2,2>>
+
+{p=PQ (QR R1) ; q=Q1}    = <<2,2,1>,<1>>
+{p=PQ (QR R1) ; q=QR R1} = <<2,2,1>,<2,1>>
+{p=PQ (QR R1) ; q=QR R2} = <<2,2,1>,<2,2>>
+
+{p=PQ (QR R2) ; q=Q1}    = <<2,2,2>,<1>>
+{p=PQ (QR R2) ; q=QR R1} = <<2,2,2>,<2,1>>
+{p=PQ (QR R2) ; q=QR R2} = <<2,2,2>,<2,2>>
+
+
+{pp: {p:P} ; q:Q} => Str
+
+{pp={p=P1} ; q=Q1}            = <<<1>>,<1>>
+{pp={p=P1} ; q=QR R1}         = <<<1>>,<2,1>>
+{pp={p=P1} ; q=QR R2}         = <<<1>>,<2,2>>
+
+{pp={p=PQ Q1} ; q=Q1}         = <<<2,1>>, <1>>
+{pp={p=PQ Q1} ; q=QR R1}      = <<<2,1>>, <2,1>>
+{pp={p=PQ Q1} ; q=QR R2}      = <<<2,1>>, <2,2>>
+
+{pp={p=PQ (QR R1)} ; q=Q1}    = <<<2,2,1>>,<1>>
+{pp={p=PQ (QR R1)} ; q=QR R1} = <<<2,2,1>>,<2,1>>
+{pp={p=PQ (QR R1)} ; q=QR R2} = <<<2,2,1>>,<2,2>>
+
+{pp={p=PQ (QR R2)} ; q=Q1}    = <<<2,2,2>>,<1>>
+{pp={p=PQ (QR R2)} ; q=QR R1} = <<<2,2,2>>,<2,1>>
+{pp={p=PQ (QR R2)} ; q=QR R2} = <<<2,2,2>>,<2,2>>

testsuite/lpgf/bench.hs

@@ -0,0 +1,184 @@
+module Main where
+
+import qualified LPGF
+import qualified PGF
+import qualified PGF2
+
+import GF (compileToPGF, compileToLPGF, writePGF, writeLPGF)
+import GF.Support (Options, Flags (..), Verbosity (..), noOptions, addOptions, modifyFlags)
+
+import Control.DeepSeq (NFData, force)
+import Control.Exception (evaluate)
+import Control.Monad (when, forM)
+import Data.Either (isLeft)
+import qualified Data.List as L
+import Data.Maybe (fromJust, isJust, isNothing)
+import qualified Data.Map as Map
+import Data.Time.Clock (getCurrentTime, diffUTCTime)
+import System.Console.ANSI
+import System.Directory (listDirectory, getFileSize)
+import System.Environment (getArgs)
+import System.Exit (die)
+import System.FilePath ((</>), (<.>), takeFileName, takeDirectory, dropExtension)
+import Text.Printf (printf)
+
+import GHC.Stats
+
+options :: Options
+options = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) noOptions
+
+usage :: String
+usage = "Arguments:\n\
+\  compile [pgf|lpgf] FoodsEng.gf FoodsGer.gf ...\n\
+\  run [pgf|pgf2|lpgf] Foods.pgf test.trees\
+\"
+
+main :: IO ()
+main = do
+  -- Parse command line arguments
+  args <- getArgs
+  let argc = length args
+  when (argc < 1) (die usage)
+  let (mode:_) = args
+  when (mode `L.notElem` ["compile","run"]) (die usage)
+  when (mode == "compile" && argc < 2) (die usage)
+  when (mode == "run" && argc < 3) (die usage)
+  let target = let a1 = args !! 1 in if a1 `elem` ["pgf", "pgf2", "lpgf"] then Just a1 else Nothing
+  let mods' = if mode == "compile" then drop (if isJust target then 2 else 1) args else []
+
+  mods <- concat <$> forM mods' (\mod ->
+    -- If * is supplied in module name, collect modules ourselves
+    if '*' `elem` mod
+    then do
+      let
+        dir = takeDirectory mod
+        pre = takeWhile (/='*') (takeFileName mod)
+        post = drop 1 $ dropWhile (/='*') (takeFileName mod)
+      map (dir </>)
+        . filter (\p -> let fn = takeFileName p in pre `L.isPrefixOf` fn && post `L.isSuffixOf` fn)
+        <$> listDirectory dir
+    else
+      return [mod]
+    )
+
+  let binaryFile = if mode == "run" then Just $ args !! (if isJust target then 2 else 1) else Nothing
+  let treesFile = if mode == "run" then Just $ args !! (if isJust target then 3 else 2) else Nothing
+
+  let doPGF = isNothing target || target == Just "pgf"
+  let doPGF2 = isNothing target || target == Just "pgf2"
+  let doLPGF = isNothing target || target == Just "lpgf"
+
+  -- Compilation
+  when (mode == "compile") $ do
+    when doPGF $ do
+      heading "PGF"
+      (path, pgf) <- time "- compile: " (compilePGF mods)
+      size <- getFileSize path
+      printf "- size: %s  %s\n" (convertSize size) path
+
+    when doLPGF $ do
+      heading "LPGF"
+      (path, lpgf) <- time "- compile: " (compileLPGF mods)
+      size <- getFileSize path
+      printf "- size: %s  %s\n" (convertSize size) path
+
+  -- Linearisation
+  when (mode == "run") $ do
+    -- Read trees
+    lns <- lines <$> readFile (fromJust treesFile)
+    let trees = map (fromJust . PGF.readExpr) lns
+    let trees2 = map (fromJust . PGF2.readExpr) lns
+    printf "Read %d trees\n" (length trees)
+
+    when doPGF $ do
+      heading "PGF"
+      pgf <- PGF.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
+      timePure "- linearise: " (linPGF pgf trees)
+      return ()
+
+    when doPGF2 $ do
+      heading "PGF2"
+      pgf <- PGF2.readPGF (dropExtension (fromJust binaryFile) <.> "pgf")
+      timePure "- linearise: " (linPGF2 pgf trees2)
+      return ()
+
+    when doLPGF $ do
+      heading "LPGF"
+      lpgf <- LPGF.readLPGF (dropExtension (fromJust binaryFile) <.> "lpgf")
+      -- timePure "- linearise: " (linLPGF lpgf trees)
+      ress <- time "- linearise: " (linLPGF' lpgf trees)
+      when (any (any isLeft) ress) $ do
+        setSGR [SetColor Foreground Dull Red]
+        putStrLn "Teminated with errors"
+        setSGR [Reset]
+
+  stats <- getRTSStats
+  printf "Max memory: %s\n" (convertSize (fromIntegral (max_mem_in_use_bytes stats)))
+
+heading :: String -> IO ()
+heading s = do
+  setSGR [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity]
+  putStrLn s
+  setSGR [Reset]
+
+-- For accurate timing, IO action must for evaluation itself (e.g., write to file)
+time :: String -> IO a -> IO a
+time desc io = do
+  start <- getCurrentTime
+  r <- io >>= evaluate -- only WHNF
+  end <- getCurrentTime
+  putStrLn $ desc ++ show (diffUTCTime end start)
+  return r
+
+-- Performs deep evaluation
+timePure :: (NFData a) => String -> a -> IO a
+timePure desc val = time desc (return $ force val)
+
+compilePGF :: [FilePath] -> IO (FilePath, PGF.PGF)
+compilePGF mods = do
+  pgf <- compileToPGF options mods
+  files <- writePGF options pgf
+  return (head files, pgf)
+
+compileLPGF :: [FilePath] -> IO (FilePath, LPGF.LPGF)
+compileLPGF mods = do
+  lpgf <- compileToLPGF options mods
+  file <- writeLPGF options lpgf
+  return (file, lpgf)
+
+linPGF :: PGF.PGF -> [PGF.Expr] -> [[String]]
+linPGF pgf trees =
+  [ map (PGF.linearize pgf lang) trees | lang <- PGF.languages pgf ]
+
+linPGF2 :: PGF2.PGF -> [PGF2.Expr] -> [[String]]
+linPGF2 pgf trees =
+  [ map (PGF2.linearize concr) trees | (_, concr) <- Map.toList (PGF2.languages pgf) ]
+
+linLPGF :: LPGF.LPGF -> [PGF.Expr] -> [[String]]
+linLPGF lpgf trees =
+  [ map (LPGF.linearizeConcrete concr) trees | (_,concr) <- Map.toList (LPGF.concretes lpgf) ]
+
+linLPGF' :: LPGF.LPGF -> [PGF.Expr] -> IO [[Either String String]]
+linLPGF' lpgf trees =
+  forM (Map.toList (LPGF.concretes lpgf)) $ \(_,concr) -> mapM (LPGF.try . LPGF.linearizeConcrete concr) trees
+
+-- | Produce human readable file size
+-- Adapted from https://hackage.haskell.org/package/hrfsize
+convertSize :: Integer -> String
+convertSize = convertSize'' . fromInteger
+
+convertSize' :: Double -> String
+convertSize' size
+  | size < 1024.0 = printf "%.0v bytes" size
+  | size < 1024.0 ^ (2 :: Int) = printf "%.2v KiB" $ size / 1024.0
+  | size < 1024.0 ^ (3 :: Int) = printf "%.2v MiB" $ size / 1024.0 ^ (2 :: Int)
+  | size < 1024.0 ^ (4 :: Int) = printf "%.2v GiB" $ size / 1024.0 ^ (3 :: Int)
+  | otherwise = printf "%.2v TiB" $ size / 1024.0 ^ (4 :: Int)
+
+convertSize'' :: Double -> String
+convertSize'' size
+  | size < 1000 = printf "%.0v bytes" size
+  | size < 1000 ^ (2 :: Int) = printf "%.2v KB" $ size / 1000
+  | size < 1000 ^ (3 :: Int) = printf "%.2v MB" $ size / 1000 ^ (2 :: Int)
+  | size < 1000 ^ (4 :: Int) = printf "%.2v GB" $ size / 1000 ^ (3 :: Int)
+  | otherwise = printf "%.2v TB" $ size / 1000 ^ (4 :: Int)

testsuite/lpgf/foods/CharactersGla.gf

@@ -0,0 +1,13 @@
+--# -coding=latin1
+resource CharactersGla = {
+	
+	--Character classes
+	oper
+		vowel : pattern Str = #("a"|"e"|"i"|"o"|"u"|"à"|"è"|"ì"|"ò"|"ù") ;
+		vowelCap : pattern Str = #("A"|"E"|"I"|"O"|"U"|"À"|"É"|"Ì"|"Ò"|"Ù") ;
+		consonant : pattern Str = #("b"|"c"|"d"|"f"|"g"|"h"|"j"|"k"|"l"|"m"|"n"|"p"|"q"|"r"|"s"|"t"|"v"|"w"|"x"|"z") ;
+		consonantCap : pattern Str = #("B"|"C"|"D"|"F"|"G"|"H"|"J"|"K"|"L"|"M"|"N"|"P"|"Q"|"R"|"S"|"T"|"V"|"W"|"X"|"Z") ;
+		broadVowel : pattern Str = #("a"|"o"|"u"|"à"|"ò"|"ù") ;
+		slenderVowel : pattern Str = #("e"|"i"|"è"|"ì") ;
+	
+}

testsuite/lpgf/foods/CharactersGle.gf

@@ -0,0 +1,13 @@
+--# -coding=latin1
+resource CharactersGle = {
+	
+	--Character classes
+	oper
+		vowel : pattern Str = #("a"|"e"|"i"|"o"|"u"|"á"|"é"|"í"|"ó"|"ú") ;
+		vowelCap : pattern Str = #("A"|"E"|"I"|"O"|"U"|"Á"|"É"|"Í"|"Ó"|"Ú") ;
+		consonant : pattern Str = #("b"|"c"|"d"|"f"|"g"|"h"|"j"|"k"|"l"|"m"|"n"|"p"|"q"|"r"|"s"|"t"|"v"|"w"|"x"|"z") ;
+		consonantCap : pattern Str = #("B"|"C"|"D"|"F"|"G"|"H"|"J"|"K"|"L"|"M"|"N"|"P"|"Q"|"R"|"S"|"T"|"V"|"W"|"X"|"Z") ;
+		broadVowel : pattern Str = #("a"|"o"|"u"|"á"|"ó"|"ú") ;
+		slenderVowel : pattern Str = #("e"|"i"|"é"|"í") ;
+	
+}

testsuite/lpgf/foods/Foods.gf

@@ -0,0 +1,15 @@
+-- (c) 2009 Aarne Ranta under LGPL
+
+abstract Foods = {
+  flags startcat = Comment ;
+  cat
+    Comment ; Item ; Kind ; Quality ;
+  fun
+    Pred : Item -> Quality -> Comment ;
+    This, That, These, Those : Kind -> Item ;
+    Mod : Quality -> Kind -> Kind ;
+    Wine, Cheese, Fish, Pizza : Kind ;
+    Very : Quality -> Quality ;
+    Fresh, Warm, Italian,
+      Expensive, Delicious, Boring : Quality ;
+}

testsuite/lpgf/foods/Foods.treebank

@@ -0,0 +1,185 @@
+Foods: Pred (That Wine) Delicious
+FoodsAfr: daardie wyn is heerlik
+FoodsAmh: ያ ወይን ጣፋጭ ነው::
+FoodsBul: онова вино е превъзходно
+FoodsCat: aquell vi és deliciós
+FoodsChi: 那 瓶 酒 是 美 味 的
+FoodsCze: tamto víno je vynikající
+FoodsDut: die wijn is lekker
+FoodsEng: that wine is delicious
+FoodsEpo: tiu vino estas bongusta
+FoodsFin: tuo viini on herkullinen
+FoodsFre: ce vin est délicieux
+FoodsGer: jener Wein ist köstlich
+FoodsGla: tha an fìon sin blasta
+FoodsGle: tá an fíon sin blasta
+FoodsHeb: היין ההוא טעים
+FoodsHin: वह मदिरा स्वादिष्ट है
+FoodsIce: þetta vín er ljúffengt
+FoodsIta: quel vino è delizioso
+FoodsJpn: その ワインは おいしい
+FoodsLat: id vinum est iucundum
+FoodsLav: tas vīns ir garšīgs
+FoodsMkd: она вино е вкусно
+FoodsMlt: dak l- inbid tajjeb
+FoodsMon: тэр дарс бол амттай
+FoodsNep: त्यो रक्सी स्वादिष्ट छ
+FoodsOri: ସେଇ ମଦ ସ୍ଵାଦିସ୍ଟ ଅଟେ
+FoodsPes: آن شراب لذىذ است
+FoodsPor: esse vinho é delicioso
+FoodsRon: acel vin este delicios
+FoodsSpa: ese vino es delicioso
+FoodsSwe: det där vinet är läckert
+FoodsTha: เหล้าองุ่น ขวด นั้น อร่อย
+FoodsTsn: bojalwa boo bo monate
+FoodsTur: şu şarap lezzetlidir
+FoodsUrd: وہ شراب مزیدار ہے
+
+Foods: Pred (This Pizza) (Very Boring)
+FoodsAfr: hierdie pizza is baie vervelig
+FoodsAmh: ይህ [Pizza] በጣም አስቀያሚ ነው::
+FoodsBul: тази пица е много еднообразна
+FoodsCat: aquesta pizza és molt aburrida
+FoodsChi: 这 张 比 萨 饼 是 非 常 难 吃 的
+FoodsCze: tato pizza je velmi nudná
+FoodsDut: deze pizza is erg saai
+FoodsEng: this pizza is very boring
+FoodsEpo: ĉi tiu pico estas tre enuiga
+FoodsFin: tämä pizza on erittäin tylsä
+FoodsFre: cette pizza est très ennuyeuse
+FoodsGer: diese Pizza ist sehr langweilig
+FoodsGla: tha an pizza seo glè leamh
+FoodsGle: tá an píotsa seo an-leamh
+FoodsHeb: הפיצה הזאת מאוד משעממת
+FoodsHin: यह पिज़्ज़ा अति अरुचिकर है
+FoodsIce: þessi flatbaka er mjög leiðinleg
+FoodsIta: questa pizza è molto noiosa
+FoodsJpn: この ピザは とても つまらない
+FoodsLat: haec placenta neapolitana est valde fluens
+FoodsLav: šī pica ir ļoti garlaicīga
+FoodsMkd: оваа пица е многу досадна
+FoodsMlt: din il- pizza tad-dwejjaq ħafna
+FoodsMon: энэ пицца бол маш амтгүй
+FoodsNep: यो पिज्जा धेरै नमिठा छ
+FoodsOri: ଏଇ ପିଜଜ଼ା ଅତି ଅରୁଚିକର ଅଟେ
+FoodsPes: این پیتزا خیلی ملال آور است
+FoodsPor: esta pizza é muito chata
+FoodsRon: această pizza este foarte plictisitoare
+FoodsSpa: esta pizza es muy aburrida
+FoodsSwe: den här pizzan är mycket tråkig
+FoodsTha: พิซซา ถาด นี้ น่าเบิ่อ มาก
+FoodsTsn: pizza e e bosula thata
+FoodsTur: bu pizza çok sıkıcıdır
+FoodsUrd: یھ پیزہ بہت فضول ہے
+
+Foods: Pred (This Cheese) Fresh
+FoodsAfr: hierdie kaas is vars
+FoodsAmh: ይህ አይብ አዲስ ነው::
+FoodsBul: това сирене е свежо
+FoodsCat: aquest formatge és fresc
+FoodsChi: 这 块 奶 酪 是 新 鲜 的
+FoodsCze: tento sýr je čerstvý
+FoodsDut: deze kaas is vers
+FoodsEng: this cheese is fresh
+FoodsEpo: ĉi tiu fromaĝo estas freŝa
+FoodsFin: tämä juusto on tuore
+FoodsFre: ce fromage est frais
+FoodsGer: dieser Käse ist frisch
+FoodsGla: tha an càise seo úr
+FoodsGle: tá an cháis seo úr
+FoodsHeb: הגבינה הזאת טריה
+FoodsHin: यह पनीर ताज़ा है
+FoodsIce: þessi ostur er ferskur
+FoodsIta: questo formaggio è fresco
+FoodsJpn: この チーズは 新鮮 だ
+FoodsLat: hoc formaticum est recens
+FoodsLav: šis siers ir svaigs
+FoodsMkd: ова сирење е свежо
+FoodsMlt: dan il- ġobon frisk
+FoodsMon: энэ бяслаг бол шинэ
+FoodsNep: यो चिज ताजा छ
+FoodsOri: ଏଇ ଛେନା ତାଜା ଅଟେ
+FoodsPes: این پنیر تازه است
+FoodsPor: este queijo é fresco
+FoodsRon: această brânză este proaspătă
+FoodsSpa: este queso es fresco
+FoodsSwe: den här osten är färsk
+FoodsTha: เนยแข็ง ก้อน นี้ สด
+FoodsTsn: kase e e ntsha
+FoodsTur: bu peynir tazedir
+FoodsUrd: یھ پنیر تازہ ہے
+
+Foods: Pred (Those Fish) Warm
+FoodsAfr: daardie visse is warm
+FoodsAmh: [Those] ትኩስ ነው::
+FoodsBul: онези риби са горещи
+FoodsCat: aquells peixos són calents
+FoodsChi: 那 几 条 鱼 是 温 热 的
+FoodsCze: tamty ryby jsou teplé
+FoodsDut: die vissen zijn warm
+FoodsEng: those fish are warm
+FoodsEpo: tiuj fiŝoj estas varmaj
+FoodsFin: nuo kalat ovat lämpimiä
+FoodsFre: ces poissons sont chauds
+FoodsGer: jene Fische sind warm
+FoodsGla: tha na h-èisg sin blàth
+FoodsGle: tá na héisc sin te
+FoodsHeb: הדגים ההם חמים
+FoodsHin: वे मछलीयँा गरम हैं
+FoodsIce: þessir fiskar eru heitir
+FoodsIta: quei pesci sono caldi
+FoodsJpn: その 魚は あたたかい
+FoodsLat: ei pisces sunt calidi
+FoodsLav: tās zivis ir siltas
+FoodsMkd: оние риби се топли
+FoodsMlt: dawk il- ħut sħan
+FoodsMon: тэдгээр загаснууд бол халуун
+FoodsNep: ती माछाहरु तातो छन्
+FoodsOri: ସେଇ ମାଛ ଗୁଡିକ ଗରମ ଅଟେ
+FoodsPes: آن ماهىها گرم هستند
+FoodsPor: esses peixes são quentes
+FoodsRon: acei peşti sunt calzi
+FoodsSpa: esos pescados son calientes
+FoodsSwe: de där fiskarna är varma
+FoodsTha: ปลา ตัว นั้น อุ่น
+FoodsTsn: dithlapi tseo di bothitho
+FoodsTur: şu balıklar ılıktır
+FoodsUrd: وہ مچھلیاں گرم ہیں
+
+Foods: Pred (That (Mod Boring (Mod Italian Pizza))) Expensive
+FoodsAfr: daardie vervelige Italiaanse pizza is duur
+FoodsAmh: ያ አስቀያሚ የጥልያን [Pizza] ውድ ነው::
+FoodsBul: онази еднообразна италианска пица е скъпа
+FoodsCat: aquella pizza italiana aburrida és cara
+FoodsChi: 那 张 又 难 吃 又 意 大 利 式 的 比 萨 饼 是 昂 贵 的
+FoodsCze: tamta nudná italská pizza je drahá
+FoodsDut: die saaie Italiaanse pizza is duur
+FoodsEng: that boring Italian pizza is expensive
+FoodsEpo: tiu enuiga itala pico estas altekosta
+FoodsFin: tuo tylsä italialainen pizza on kallis
+FoodsFre: cette pizza italienne ennuyeuse est chère
+FoodsGer: jene langweilige italienische Pizza ist teuer
+FoodsGla: tha an pizza Eadailteach leamh sin daor
+FoodsGle: tá an píotsa Iodálach leamh sin daor
+FoodsHeb: הפיצה האיטלקית המשעממת ההיא יקרה
+FoodsHin: वह अरुचिकर इटली पिज़्ज़ा बहुमूल्य है
+FoodsIce: þessi leiðinlega ítalska flatbaka er dýr
+FoodsIta: quella pizza italiana noiosa è cara
+FoodsJpn: その つまらない イタリアの ピザは たかい
+FoodsLat: ea placenta itala fluens neapolitana est pretiosa
+FoodsLav: tā garlaicīgā itāļu pica ir dārga
+FoodsMkd: онаа досадна италијанска пица е скапа
+FoodsMlt: dik il- pizza Taljana tad-dwejjaq għalja
+FoodsMon: тэр амтгүй итали пицца бол үнэтэй
+FoodsNep: त्यो नमिठा इटालियन पिज्जा महँगो छ
+FoodsOri: ସେଇ ଅରୁଚିକର ଇଟାଲି ପିଜଜ଼ା ମୁଲ୍ୟବାନ୍ ଅଟେ
+FoodsPes: آن پیتزا ایتالیایی ى ملال آور گران است
+FoodsPor: essa pizza Italiana chata é cara
+FoodsRon: acea pizza italiană plictisitoare este scumpă
+FoodsSpa: esa pizza italiana aburrida es cara
+FoodsSwe: den där tråkiga italienska pizzan är dyr
+FoodsTha: พิซซา อิตาลี น่าเบิ่อ ถาด นั้น แพง
+FoodsTsn: pizza eo ya ga Itali le e e bosula e a tura
+FoodsTur: şu sıkıcı İtalyan pizzası pahalıdır
+FoodsUrd: وہ فضول اٹا لوی پیزہ مہنگا ہے
+

testsuite/lpgf/foods/Foods.trees

@@ -0,0 +1,5 @@
+Pred (That Wine) Delicious
+Pred (This Pizza) (Very Boring)
+Pred (This Cheese) Fresh
+Pred (Those Fish) Warm
+Pred (That (Mod Boring (Mod Italian Pizza))) Expensive

testsuite/lpgf/foods/FoodsAfr.gf

@@ -0,0 +1,77 @@
+-- (c) 2009 Laurette Pretorius Sr & Jr and Ansu Berg under LGPL
+--# -coding=latin1
+
+concrete FoodsAfr of Foods = open Prelude, Predef in{
+	lincat
+		Comment = {s: Str} ;
+		Kind = {s: Number => Str} ;
+		Item = {s: Str ; n: Number} ;
+		Quality = {s: AdjAP => Str} ;
+		
+	lin	
+		Pred item quality = {s = item.s ++ "is" ++ (quality.s ! Predic)};
+		This kind = {s = "hierdie" ++ (kind.s ! Sg); n = Sg};
+		That kind = {s = "daardie" ++ (kind.s ! Sg); n = Sg};
+		These kind = {s = "hierdie" ++ (kind.s ! Pl); n = Pl};
+		Those kind = {s = "daardie" ++ (kind.s ! Pl); n = Pl};
+		Mod quality kind = {s = table{n => (quality.s ! Attr) ++ (kind.s!n)}};
+		
+		Wine = declNoun_e "wyn";
+		Cheese = declNoun_aa "kaas";
+		Fish = declNoun_ss "vis";
+		Pizza = declNoun_s "pizza";
+		
+		Very quality = veryAdj quality;
+		
+		Fresh = regAdj "vars";
+		Warm = regAdj "warm";
+		Italian = smartAdj_e "Italiaans";
+		Expensive = regAdj "duur";
+		Delicious = smartAdj_e "heerlik";
+		Boring = smartAdj_e "vervelig";
+		
+	param
+		AdjAP = Attr | Predic ;
+		Number = Sg | Pl ;
+	
+	oper
+		--Noun operations (wyn, kaas, vis, pizza)
+		
+		declNoun_aa: Str -> {s: Number => Str} = \x ->
+		let v = tk 2 x
+		in
+		{s = table{Sg => x ; Pl => v + (last x) +"e"}}; 
+		
+		declNoun_e: Str -> {s: Number => Str} = \x -> {s = table{Sg => x ; Pl => x + "e"}} ;
+		declNoun_s: Str -> {s: Number => Str} = \x -> {s = table{Sg => x ; Pl => x + "s"}} ;
+		
+		declNoun_ss: Str -> {s: Number => Str} = \x -> {s = table{Sg => x ; Pl => x + (last x) + "e"}} ;
+
+		
+		--Adjective operations
+		
+		mkAdj : Str -> Str -> {s: AdjAP => Str} = \x,y -> {s = table{Attr => x; Predic => y}};
+		
+		declAdj_e : Str -> {s : AdjAP=> Str} = \x -> mkAdj (x + "e") x;
+		declAdj_g : Str -> {s : AdjAP=> Str} = \w ->
+			let v = init w
+			in mkAdj (v + "ë") w ;
+		
+		declAdj_oog : Str -> {s : AdjAP=> Str} = \w ->
+			let v = init w
+			in 
+				let i = init v
+				in mkAdj (i + "ë") w ;
+					
+		regAdj : Str -> {s : AdjAP=> Str} = \x -> mkAdj x x;
+		
+		veryAdj : {s: AdjAP => Str} -> {s : AdjAP=> Str} =  \x -> {s = table{a => "baie" ++ (x.s!a)}};
+		
+		
+		smartAdj_e : Str -> {s : AdjAP=> Str} = \a -> case a of 
+		{
+			_ + "oog" 			   		=> declAdj_oog a ;
+			_ + ("e" | "ie" | "o" | "oe") + "g" 	=> declAdj_g a ;
+			_					   	=> declAdj_e a 
+		};
+}

testsuite/lpgf/foods/FoodsAmh.gf

@@ -0,0 +1,21 @@
+concrete FoodsAmh of Foods ={
+ flags coding = utf8;
+ lincat
+  Comment,Item,Kind,Quality = Str;
+ lin
+  Pred item quality = item ++ quality++ "ነው::" ;
+  This kind = "ይህ" ++ kind;
+  That kind = "ያ" ++ kind;
+  Mod quality kind = quality ++ kind;
+  Wine = "ወይን";
+  Cheese = "አይብ";
+  Fish = "ዓሳ";
+  Very quality = "በጣም" ++ quality;
+  Fresh = "አዲስ";
+  Warm = "ትኩስ";
+  Italian = "የጥልያን";
+  Expensive = "ውድ";
+  Delicious = "ጣፋጭ";
+  Boring = "አስቀያሚ";
+  
+}   

testsuite/lpgf/foods/FoodsBul.gf

@@ -0,0 +1,43 @@
+-- (c) 2009 Krasimir Angelov under LGPL
+
+concrete FoodsBul of Foods = {
+
+  flags
+    coding = utf8;
+
+  param
+    Gender = Masc | Fem | Neutr;
+    Number = Sg | Pl;
+    Agr    = ASg Gender | APl ;
+
+  lincat
+    Comment = Str ;
+    Quality = {s : Agr => Str} ;
+    Item = {s : Str; a : Agr} ;
+    Kind = {s : Number => Str; g : Gender} ;
+
+  lin
+    Pred item qual = item.s ++ case item.a of {ASg _ => "е"; APl => "са"} ++ qual.s ! item.a ;
+
+    This  kind = {s=case kind.g of {Masc=>"този"; Fem=>"тази";  Neutr=>"това" } ++ kind.s ! Sg; a=ASg kind.g} ;
+    That  kind = {s=case kind.g of {Masc=>"онзи"; Fem=>"онази"; Neutr=>"онова"} ++ kind.s ! Sg; a=ASg kind.g} ;
+    These kind = {s="тези"  ++ kind.s ! Pl; a=APl} ;
+    Those kind = {s="онези" ++ kind.s ! Pl; a=APl} ;
+
+    Mod qual kind = {s=\\n => qual.s ! (case n of {Sg => ASg kind.g; Pl => APl}) ++ kind.s ! n; g=kind.g} ;
+
+    Wine   = {s = table {Sg => "вино";   Pl => "вина"};   g = Neutr};
+    Cheese = {s = table {Sg => "сирене"; Pl => "сирена"}; g = Neutr};
+    Fish   = {s = table {Sg => "риба";   Pl => "риби"};   g = Fem};
+    Pizza  = {s = table {Sg => "пица";   Pl => "пици"};   g = Fem};
+
+    Very qual = {s = \\g => "много" ++ qual.s ! g};
+
+    Fresh     = {s = table {ASg Masc => "свеж";        ASg Fem => "свежа";       ASg Neutr => "свежо";       APl => "свежи"}};
+    Warm      = {s = table {ASg Masc => "горещ";       ASg Fem => "гореща";      ASg Neutr => "горещо";      APl => "горещи"}};
+    Italian   = {s = table {ASg Masc => "италиански";  ASg Fem => "италианска";  ASg Neutr => "италианско";  APl => "италиански"}};
+    Expensive = {s = table {ASg Masc => "скъп";        ASg Fem => "скъпа";       ASg Neutr => "скъпо";       APl => "скъпи"}};
+    Delicious = {s = table {ASg Masc => "превъзходен"; ASg Fem => "превъзходна"; ASg Neutr => "превъзходно"; APl => "превъзходни"}};
+    Boring    = {s = table {ASg Masc => "еднообразен"; ASg Fem => "еднообразна"; ASg Neutr => "еднообразно"; APl => "еднообразни"}};
+
+}

testsuite/lpgf/foods/FoodsCat.gf

@@ -0,0 +1,6 @@
+
+-- (c) 2009 Jordi Saludes under LGPL
+
+concrete FoodsCat of Foods = FoodsI with 
+  (Syntax = SyntaxCat),
+  (LexFoods = LexFoodsCat) ;

testsuite/lpgf/foods/FoodsChi.gf

@@ -0,0 +1,56 @@
+concrete FoodsChi of Foods = open Prelude in {
+flags coding = utf8 ;
+lincat
+    Comment, Item = Str;
+    Kind = knd ;
+    Quality = qual ;
+lin
+    Pred = (\itm, ql ->
+      case ql.hasVery of {
+        True  => itm ++ "是 非 常" ++ ql.s ++ ql.p ;
+        False => itm ++ "是"       ++ ql.s ++ ql.p } ) ;
+    This kind = "这" ++ kind.c ++ kind.m ++ kind.s ;
+    That kind = "那" ++ kind.c ++ kind.m ++ kind.s ;
+    These kind = "这" ++ "几" ++ kind.c ++ kind.m ++ kind.s ;
+    Those kind = "那" ++ "几" ++ kind.c ++ kind.m ++ kind.s ;
+    Mod = modifier ;
+
+    Wine  = geKind "酒" "瓶" ;
+    Pizza = geKind "比 萨 饼" "张" ;
+    Cheese  = geKind "奶 酪" "块";
+    Fish  = geKind "鱼" "条";
+
+    Very = (\q -> {s = q.s ; p = q.p ; hasVery = True}) ;
+    Fresh  = longQuality "新 鲜" ;
+    Warm  = longQuality "温 热" ;
+    Italian  = longQuality "意 大 利 式" ;
+    Expensive  = longQuality "昂 贵" ;
+    Delicious  = longQuality "美 味" ;
+     -- this technically translates to "unpalatable" instead of boring
+    Boring  = longQuality "难 吃" ;
+
+oper
+    -- lincat aliases
+    qual : Type = {s,p : Str ; hasVery : Bool} ;
+    knd  : Type = {s,c,m : Str; hasMod : Bool} ;
+
+    -- Constructor functions
+    mkKind : Str -> Str -> knd = \s,c ->
+      {s = s ; c = c; m = ""; hasMod = False} ;
+    geKind : Str -> Str -> knd = \s,cl ->
+      mkKind s (classifier cl) ;
+    longQuality : Str -> qual = \s ->
+      {s = s ; p = "的" ; hasVery = False}  ;
+    modifier : qual -> knd -> knd = \q,k ->
+      { s = k.s ; c = k.c ; m = modJoin k.hasMod q k.m ;
+        hasMod = True } ;
+
+    -- Helper functions
+    classifier : Str -> Str = \s ->
+      case s of {"" => "个" ; _  => s };
+    modJoin : Bool -> qual  -> Str -> Str = \bool, q,m ->
+      case bool of {
+        True  => "又" ++ q.s ++ "又" ++ m ;
+        False => q.s ++ q.p } ;
+
+}

testsuite/lpgf/foods/FoodsCze.gf

@@ -0,0 +1,35 @@
+-- (c) 2011 Katerina Bohmova under LGPL
+
+concrete FoodsCze of Foods = open ResCze in {
+  flags 
+    coding = utf8 ;
+  lincat
+    Comment = {s : Str} ; 
+    Quality = Adjective ; 
+    Kind = Noun ; 
+    Item = NounPhrase ;
+  lin
+    Pred item quality = 
+      {s = item.s ++ copula ! item.n ++ 
+           quality.s ! item.g ! item.n} ;
+    This  = det Sg "tento" "tato" "toto" ;
+    That  = det Sg "tamten" "tamta" "tamto" ;
+    These = det Pl "tyto" "tyto" "tato" ;
+    Those = det Pl "tamty" "tamty" "tamta" ;
+    Mod quality kind = {
+      s = \\n => quality.s ! kind.g ! n ++ kind.s ! n ;
+      g = kind.g
+      } ;
+    Wine = noun "víno" "vína" Neutr ;
+    Cheese = noun "sýr" "sýry" Masc ;
+    Fish = noun "ryba" "ryby" Fem ;
+    Pizza = noun "pizza" "pizzy" Fem ;
+    Very qual = {s = \\g,n => "velmi" ++ qual.s ! g ! n} ;
+    Fresh = regAdj "čerstv" ;
+    Warm = regAdj "tepl" ;
+    Italian = regAdj "italsk" ;
+    Expensive = regAdj "drah" ;
+    Delicious = regnfAdj "vynikající" ;
+    Boring = regAdj "nudn" ;
+}
+

testsuite/lpgf/foods/FoodsDut.gf

@@ -0,0 +1,58 @@
+-- (c) 2009 Femke Johansson under LGPL
+
+concrete FoodsDut of Foods = {
+
+	lincat
+		Comment = {s : Str};
+		Quality = {s : AForm => Str};
+		Kind = { s : Number => Str};
+		Item = {s : Str ; n : Number};
+	
+	lin
+		Pred item quality = 
+			{s = item.s ++ copula ! item.n ++ quality.s ! APred};
+		This = det Sg "deze";
+		These = det Pl "deze";
+		That = det Sg "die";
+		Those = det Pl "die";
+		
+		Mod quality kind =
+			{s = \\n => quality.s ! AAttr ++ kind.s ! n};
+			Wine = regNoun "wijn";
+			Cheese = noun "kaas" "kazen";
+			Fish = noun "vis" "vissen";
+			Pizza = noun "pizza" "pizza's";
+			
+			Very a = {s = \\f => "erg" ++ a.s ! f};
+			
+			Fresh = regadj "vers";
+			Warm = regadj "warm";
+			Italian = regadj "Italiaans";
+			Expensive = adj "duur" "dure";
+			Delicious = regadj "lekker";
+			Boring = regadj "saai";
+		
+		param
+			Number = Sg | Pl;
+			AForm = APred | AAttr;
+		
+		oper
+			det : Number -> Str ->
+				{s : Number => Str} -> {s : Str ; n: Number} =
+				\n,det,noun -> {s = det ++ noun.s ! n ; n=n};
+				
+			noun : Str -> Str -> {s : Number => Str} = 
+				\man,men -> {s = table {Sg => man; Pl => men}};
+				
+			regNoun : Str -> {s : Number => Str} =
+				\wijn -> noun wijn (wijn + "en");
+				
+			regadj : Str -> {s : AForm => Str} =
+				\koud -> adj koud (koud+"e");
+			
+			adj : Str -> Str -> {s : AForm => Str} =
+				\duur, dure -> {s = table {APred => duur; AAttr => dure}};
+				
+			copula : Number => Str =
+				table {Sg => "is" ; Pl => "zijn"};
+}

testsuite/lpgf/foods/FoodsEng.gf

@@ -0,0 +1,43 @@
+-- (c) 2009 Aarne Ranta under LGPL
+
+concrete FoodsEng of Foods = {
+  flags language = en_US;
+  lincat
+    Comment, Quality = {s : Str} ; 
+    Kind = {s : Number => Str} ; 
+    Item = {s : Str ; n : Number} ; 
+  lin
+    Pred item quality = 
+      {s = item.s ++ copula ! item.n ++ quality.s} ;
+    This  = det Sg "this" ;
+    That  = det Sg "that" ;
+    These = det Pl "these" ;
+    Those = det Pl "those" ;
+    Mod quality kind = 
+      {s = \\n => quality.s ++ kind.s ! n} ;
+    Wine = regNoun "wine" ;
+    Cheese = regNoun "cheese" ;
+    Fish = noun "fish" "fish" ;
+    Pizza = regNoun "pizza" ;
+    Very a = {s = "very" ++ a.s} ;
+    Fresh = adj "fresh" ;
+    Warm = adj "warm" ;
+    Italian = adj "Italian" ;
+    Expensive = adj "expensive" ;
+    Delicious = adj "delicious" ;
+    Boring = adj "boring" ;
+  param
+    Number = Sg | Pl ;
+  oper
+    det : Number -> Str -> 
+      {s : Number => Str} -> {s : Str ; n : Number} = 
+        \n,det,noun -> {s = det ++ noun.s ! n ; n = n} ;
+    noun : Str -> Str -> {s : Number => Str} = 
+      \man,men -> {s = table {Sg => man ; Pl => men}} ;
+    regNoun : Str -> {s : Number => Str} = 
+      \car -> noun car (car + "s") ;
+    adj : Str -> {s : Str} = 
+      \cold -> {s = cold} ;
+    copula : Number => Str = 
+      table {Sg => "is" ; Pl => "are"} ;
+}

testsuite/lpgf/foods/FoodsEpo.gf

@@ -0,0 +1,48 @@
+-- (c) 2009 Julia Hammar under LGPL
+
+concrete FoodsEpo of Foods = open Prelude in {
+
+  flags coding =utf8 ;
+
+  lincat
+    Comment = SS ; 
+    Kind, Quality = {s : Number => Str} ; 
+    Item = {s : Str ; n : Number} ; 
+
+  lin
+    Pred item quality = ss (item.s ++ copula ! item.n ++ quality.s ! item.n) ;
+    This = det Sg "ĉi tiu" ;
+    That  = det Sg "tiu" ;
+    These = det Pl "ĉi tiuj" ;
+    Those = det Pl "tiuj" ;
+    Mod quality kind = {s = \\n => quality.s ! n ++ kind.s ! n} ;
+    Wine = regNoun "vino" ;
+    Cheese = regNoun "fromaĝo" ;
+    Fish = regNoun "fiŝo" ;
+    Pizza = regNoun "pico" ;
+    Very quality = {s = \\n => "tre" ++ quality.s ! n} ;
+    Fresh = regAdj "freŝa" ;
+    Warm = regAdj "varma" ;
+    Italian = regAdj "itala" ;
+    Expensive = regAdj "altekosta" ;
+    Delicious = regAdj "bongusta" ;
+    Boring = regAdj "enuiga" ;
+
+  param
+    Number = Sg | Pl ;
+
+  oper
+    det : Number -> Str -> {s : Number => Str} -> {s : Str ; n : Number} = 
+      \n,d,cn -> {
+        s = d ++ cn.s ! n ;
+        n = n
+      } ;
+    regNoun : Str -> {s : Number => Str} = 
+      \vino -> {s = table {Sg => vino ; Pl => vino + "j"}
+	} ;
+    regAdj : Str -> {s : Number => Str} =
+      \nova -> {s = table {Sg => nova ; Pl => nova + "j"}
+      } ;
+    copula : Number => Str = \\_ => "estas" ;
+}
+