Add run-on-grammar canonical test script

It's possible that more constructors need to be handled

.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
+    - name: Test
-    #   run: |
+      run: |
-    #     stack test --system-ghc
+        stack test --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml

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

.gitignore

@@ -5,7 +5,6 @@
 *.jar
 *.gfo
 *.pgf
-*.lpgf
 debian/.debhelper
 debian/debhelper-build-stamp
 debian/gf
@@ -54,6 +53,10 @@ 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,13 +30,16 @@ GF particularly addresses four aspects of grammars:
 
 ## Compilation and installation
 
-The simplest way of installing GF is with the command:
+The simplest way of installing GF from source is with the command:
 ```
 cabal install
 ```
+or:
+```
+stack install
+```
 
-For more details, see the [download page](http://www.grammaticalframework.org/download/index.html)
+For more information, including links to precompiled binaries, 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,6 +45,8 @@ 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,6 +26,14 @@ 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)
@@ -50,11 +58,8 @@ buildWeb gf flags (pkg,lbi) = do
   contrib_exists <- doesDirectoryExist contrib_dir
   if contrib_exists
   then mapM_ build_pgf example_grammars
-  else putStr $ unlines
+  -- else noContribMsg
-    [ "Example grammars are no longer included in the main GF repository, but have moved to gf-contrib."
+  else return ()
-    , "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,15 +49,17 @@ 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 release from source
+## Installing the latest Hackage release (macOS, Linux, and WSL2 on Windows)
 
 [GF is on Hackage](http://hackage.haskell.org/package/gf), so under
 normal circumstances the procedure is fairly simple:
 
-1.  Install a recent version of the [Haskell Platform](http://hackage.haskell.org/platform) (see note below)
+1.  Install ghcup https://www.haskell.org/ghcup/
-2.  `cabal update`
+2.  `ghcup install ghc 8.10.4`
-3.  On Linux: install some C libraries from your Linux distribution (see note below)
+3.  `ghcup set ghc 8.10.4`
-4.  `cabal install gf`
+4.  `cabal update`
+5.  On Linux: install some C libraries from your Linux distribution (see note below)
+6.  `cabal install gf-3.11`
 
 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**.
@@ -74,17 +76,6 @@ 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,6 +14,7 @@ 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
@@ -71,7 +72,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,
@@ -86,10 +87,7 @@ 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:
@@ -110,7 +108,6 @@ Library
     PGF
     PGF.Internal
     PGF.Haskell
-    LPGF
 
   other-modules:
     PGF.Data
@@ -188,7 +185,6 @@ Library
     GF.Compile.Export
     GF.Compile.GenerateBC
     GF.Compile.GeneratePMCFG
-    GF.Compile.GrammarToLPGF
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
     GF.Compile.Optimize
@@ -218,7 +214,6 @@ Library
     GF.Data.ErrM
     GF.Data.Graph
     GF.Data.Graphviz
-    GF.Data.IntMapBuilder
     GF.Data.Relation
     GF.Data.Str
     GF.Data.Utilities
@@ -325,7 +320,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
@@ -358,403 +353,5 @@ 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,6 +228,10 @@ 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 #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-}
 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   -> error $ render (ppTcError tcErr)
+                          Left tcErr   -> errorWithoutStackTrace $ render (ppTcError tcErr)
                           Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
                                              putStrLn ("Type:        "++showType [] ty)
                                              putStrLn ("Probability: "++show (probTree pgf e))
@@ -1019,3 +1019,7 @@ 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/Compile.hs

@@ -1,7 +1,6 @@
-module GF.Compile (compileToPGF, compileToLPGF, link, linkl, batchCompile, srcAbsName) where
+module GF.Compile (compileToPGF, link, 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)
@@ -15,7 +14,7 @@ import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb,
                       justModuleName,extendPathEnv,putStrE,putPointE)
 import GF.Data.Operations(raise,(+++),err)
 
-import Control.Monad(foldM,when,(<=<),filterM)
+import Control.Monad(foldM,when,(<=<),filterM,liftM)
 import GF.System.Directory(doesFileExist,getModificationTime)
 import System.FilePath((</>),isRelative,dropFileName)
 import qualified Data.Map as Map(empty,insert,elems) --lookup
@@ -25,16 +24,12 @@ 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
@@ -47,14 +42,6 @@ link opts (cnc,gr) =
     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/Compute/ConcreteNew.hs

@@ -528,7 +528,7 @@ value2term' stop loc xs v0 =
 --  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

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,identS,identW,prefixIdent)
+import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
 import GF.Infra.Option
 import GF.Haskell as H
 import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
      | let Grammar abstr cncs = grammar2canonical opts absname gr,
        cncmod<-cncs,
        let ModId name = concName cncmod
-           filename = name ++ ".hs" :: FilePath
+           filename = showRawIdent 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 "s"
+    label_s = LabelId (rawIdentS "s")
 
     signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
       where
@@ -321,7 +321,7 @@ coerce env ty t =
       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,18 +334,17 @@ coerce env ty t =
     _ -> t
   where
     app f ts = ParamConstant (Param f ts) -- !! a hack
-    to_rcon = ParamId . Unqual . to_rcon' . labels
+    to_rcon = ParamId . Unqual . rawIdentS . 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_"++l
+proj' (LabelId l) = "proj_" ++ showRawIdent l
 rcon = Var . rcon'
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
-
 to_rcon' = ("to_"++) . rcon_name
 
 recordType ls =
@@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
 
 class ToIdent i where toIdent :: i -> Ident
 
-instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
-instance ToIdent PredefId where toIdent (PredefId s) = identS s
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
-instance ToIdent CatId   where toIdent (CatId s) = identS s
+instance ToIdent CatId   where toIdent (CatId s) = identC s
-instance ToIdent C.FunId where toIdent (FunId s) = identS s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
-instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
 
-qIdentS = identS . unqual
+qIdentC = identS . unqual
 
-unqual (Qual (ModId m) n) = m++"_"++n
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
-unqual (Unqual n) = n
+unqual (Unqual n) = showRawIdent n
 
 instance ToIdent VarId where
   toIdent Anonymous = identW
-  toIdent (VarId s) = identS s
+  toIdent (VarId s) = identC s

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -6,31 +6,35 @@ 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
+import GF.Grammar.Grammar as G
 import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
+import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
-import GF.Infra.Option(Options, optionsPGF)
+import GF.Infra.Option(Options,optionsPGF)
 import PGF.Internal(Literal(..))
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
-import Debug.Trace
+import System.FilePath ((</>), (<.>))
+import qualified Debug.Trace as T
+
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
-grammar2canonical :: Options -> ModuleName -> SourceGrammar -> C.Grammar
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
 grammar2canonical opts absname gr =
    Grammar (abstract2canonical absname gr)
            (map snd (concretes2canonical opts absname gr))
 
 -- | Generate Canonical code for the named abstract syntax
+abstract2canonical :: ModuleName -> G.Grammar -> Abstract
 abstract2canonical absname gr =
     Abstract (modId absname) (convFlags gr absname) cats funs
   where
@@ -45,6 +49,7 @@ 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
@@ -55,23 +60,24 @@ 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" :: FilePath
+       let cncname = "canonical" </> render cnc <.> "gf"
            Ok cncmod = lookupModule gr cnc
   ]
 
 -- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
 concrete2canonical gr cenv absname cnc modinfo =
   Concrete (modId cnc) (modId absname) (convFlags gr cnc)
       (neededParamTypes S.empty (params defs))
-      [lincat|(_,Left lincat)<-defs]
+      [lincat | (_,Left lincat) <- defs]
-      [lin|(_,Right lin)<-defs]
+      [lin | (_,Right lin) <- defs]
   where
     defs = concatMap (toCanonical gr absname cenv) .
            M.toList $
@@ -86,6 +92,7 @@ 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 _ ->
@@ -98,7 +105,8 @@ toCanonical gr absname cenv (name,jment) =
       where
         tts = tableTypes gr [e']
 
-        e' = unAbs (length params) $
+        e' = cleanupRecordFields lincat $
+             unAbs (length params) $
              nf loc (mkAbs params (mkApp def (map Vr args)))
         params = [(b,x)|(b,x,_)<-ctx]
         args = map snd params
@@ -109,12 +117,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 =
@@ -123,6 +131,7 @@ 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)
@@ -141,11 +150,26 @@ paramTypes gr t =
                  Ok (_,ResParam {}) -> S.singleton q
                  _ -> ignore
 
-    ignore = trace ("Ignore: "++show t) S.empty
+    ignore = T.trace ("Ignore: " ++ show t) S.empty
 
+-- | Filter out record fields from definitions which don't appear in lincat.
+cleanupRecordFields :: G.Type -> Term -> Term
+cleanupRecordFields (RecType ls) (R as) =
+  let defnFields = M.fromList ls
+  in R
+      [ (lbl, (mty, t'))
+      | (lbl, (mty, t)) <- as
+      , M.member lbl defnFields
+      , let Just ty = M.lookup lbl defnFields
+      , let t' = cleanupRecordFields ty t
+      ]
+cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
+cleanupRecordFields _ t = t
 
+convert :: G.Grammar -> Term -> LinValue
 convert gr = convert' gr []
 
+convert' :: G.Grammar -> [Ident] -> Term -> LinValue
 convert' gr vs = ppT
   where
     ppT0 = convert' gr vs
@@ -163,20 +187,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 r)
+        R r -> RecordValue (fields (sortRec r))
         P t l -> projection (ppT t) (lblId l)
         Vr x -> VarValue (gId x)
         Cn x -> VarValue (gId x) -- hmm
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
         EInt n -> LiteralValue (IntConstant n)
-        Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
-        QC (m,n) -> ParamConstant (Param ((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' "++show t
+        _ -> error $ "convert' ppT: " ++ show t
 
     ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
@@ -189,12 +213,12 @@ convert' gr vs = ppT
         Ok ALL_CAPIT  -> p "ALL_CAPIT"
         _ -> VarValue (gQId cPredef n) -- hmm
       where
-       p = PredefValue . PredefId
+       p = PredefValue . PredefId . rawIdentS
 
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
-        PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
+        PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
         PR r -> RecordPattern (fields r) {-
         PW -> WildPattern
         PV x -> VarP x
@@ -203,6 +227,7 @@ 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)
@@ -219,12 +244,12 @@ convert' gr vs = ppT
         pre Empty = [""]  -- Empty == K ""
         pre (Strs ts) = concatMap pre ts
         pre (EPatt p) = pat p
-        pre t = error $ "pre "++show t
+        pre t = error $ "convert' alts pre: " ++ show t
 
         pat (PString s) = [s]
         pat (PAlt p1 p2) = pat p1++pat p2
         pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
-        pat p = error $ "pat "++show p
+        pat p = error $ "convert' alts pat: "++show p
 
     fields = map field . filter (not.isLockLabel.fst)
     field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -237,6 +262,7 @@ 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
@@ -244,21 +270,24 @@ concatValue v1 v2 =
     _ -> ConcatValue v1 v2
 
 -- | Smart constructor for projections
-projection r l = maybe (Projection r l) id (proj r l)
+projection :: LinValue -> LabelId -> LinValue
+projection r l = fromMaybe (Projection r l) (proj r l)
 
+proj :: LinValue -> LabelId -> Maybe LinValue
 proj r l =
   case r of
-    RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
+    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
@@ -277,13 +306,16 @@ 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
@@ -295,16 +327,18 @@ mightMatch v p =
     RecordValue rv ->
       case p of
         RecordPattern rp ->
-          and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
+          and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
         _ -> False
     _ -> True
 
+patVars :: Patt -> [Ident]
 patVars p =
   case p of
     PV x -> [x]
     PAs x p -> x:patVars p
     _ -> collectPattOp patVars p
 
+convType :: Term -> LinType
 convType = ppT
   where
     ppT t =
@@ -316,9 +350,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)))
+        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
-        Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
+        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
-        _ -> error $ "Missing case in convType for: "++show t
+        _ -> error $ "convType ppT: " ++ show t
 
     convFields = map convField . filter (not.isLockLabel.fst)
     convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -327,15 +361,20 @@ convType = ppT
                    "Float" -> FloatType
                    "Int" -> IntType
                    "Str" -> StrType
-                   _ -> error ("convSort "++show k)
+                   _ -> error $ "convType 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)) _)
@@ -343,7 +382,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),[]) {-
@@ -351,36 +390,46 @@ 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 = LabelId . render -- hmm
+lblId :: Label -> C.LabelId
-modId (MN m) = ModId (showIdent m)
+lblId (LIdent ri) = LabelId ri
+lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
 
-class FromIdent i where gId :: Ident -> i
+modId :: ModuleName -> C.ModId
+modId (MN m) = ModId (ident2raw m)
+
+class FromIdent i where
+  gId :: Ident -> i
 
 instance FromIdent VarId where
-  gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
+  gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
 
-instance FromIdent C.FunId where gId = C.FunId . showIdent
+instance FromIdent C.FunId where gId = C.FunId . ident2raw
-instance FromIdent CatId where gId = CatId . showIdent
+instance FromIdent CatId where gId = CatId . ident2raw
 instance FromIdent ParamId where gId = ParamId . unqual
 instance FromIdent VarValueId where gId = VarValueId . unqual
 
-class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
+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 m n = Qual (modId m) (showIdent n)
+qual :: ModuleName -> Ident -> QualId
-unqual n = Unqual (showIdent n)
+qual m n = Qual (modId m) (ident2raw n)
 
+unqual :: Ident -> QualId
+unqual n = Unqual (ident2raw n)
+
+convFlags :: G.Grammar -> ModuleName -> Flags
 convFlags gr mn =
-  Flags [(n,convLit v) |
+  Flags [(rawIdentS n,convLit v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
   where
     convLit l =

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -1,447 +0,0 @@
-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/Compiler.hs

@@ -1,11 +1,9 @@
-module GF.Compiler (mainGFC, linkGrammars, writePGF, writeLPGF, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
 
 import PGF
 import PGF.Internal(concretes,optimizePGF,unionPGF)
 import PGF.Internal(putSplitAbs,encodeFile,runPut)
-import LPGF(LPGF)
+import GF.Compile as S(batchCompile,link,srcAbsName)
-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)
@@ -13,8 +11,7 @@ import GF.Compile.GrammarToCanonical--(concretes2canonical)
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
-import GF.Grammar.CFG hiding (Grammar)
+import GF.Grammar.CFG
-import GF.Grammar.Grammar (Grammar, ModuleName)
 
 --import GF.Infra.Ident(showIdent)
 import GF.Infra.UseIO
@@ -26,11 +23,10 @@ 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,void)
+import Control.Monad(when,unless,forM_)
 
 -- | 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@)
@@ -97,10 +93,6 @@ 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")
@@ -153,7 +145,7 @@ unionPGFFiles opts fs =
              pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
          if pgfFile `elem` fs
            then putStrLnE $ "Refusing to overwrite " ++ pgfFile
-           else void $ writePGF opts pgf
+           else writePGF opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -170,39 +162,26 @@ writeOutputs opts pgf = do
 -- | Write the result of compiling a grammar (e.g. with 'compileToPGF' or
 -- 'link') to a @.pgf@ file.
 -- A split PGF file is output if the @-split-pgf@ option is used.
-writePGF :: Options -> PGF -> IOE [FilePath]
+writePGF :: Options -> PGF -> IOE ()
 writePGF opts pgf =
     if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
   where
     writeNormalPGF =
        do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
           writing opts outfile $ 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)
-         outfiles <- forM (Map.toList (concretes pgf)) $ \cnc -> do
+         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)
 
-writeLPGF :: Options -> LPGF -> IOE FilePath
+writeOutput :: Options -> FilePath-> String -> IOE ()
-writeLPGF opts lpgf = do
+writeOutput opts file str = writing opts path $ writeUTF8File path str
-  let
+  where path = outputPath opts file
-    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

@@ -1,57 +0,0 @@
--- | 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,6 +11,7 @@
 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
@@ -30,7 +31,7 @@ data TypeApp  = TypeApp CatId [Type]        deriving Show
 data TypeBinding = TypeBinding VarId Type   deriving Show
 
 --------------------------------------------------------------------------------
--- ** Concrete syntax
+-- ** Concreate syntax
 
 -- | Concrete Syntax
 data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
@@ -102,9 +103,9 @@ data TableRow  rhs = TableRow  LinPattern rhs
 
 -- *** Identifiers in Concrete Syntax
 
-newtype PredefId   = PredefId Id        deriving (Eq,Ord,Show)
+newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
-newtype LabelId    = LabelId Id         deriving (Eq,Ord,Show)
+newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
-newtype VarValueId = VarValueId QualId  deriving (Eq,Ord,Show)
+data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
 
 -- | Name of param type or param value 
 newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
@@ -115,9 +116,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,Ord,Show)
+newtype FunId = FunId Id  deriving (Eq,Show)
 
-data VarId = Anonymous | VarId Id  deriving (Eq,Show)
+data VarId = Anonymous | VarId Id  deriving Show
 
 newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
 type FlagName = Id
@@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
 
 -- *** Identifiers
 
-type Id = String
+type Id = RawIdent
 data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
@@ -265,7 +266,6 @@ instance PPA LinPattern where
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
       WildPattern     -> pp "_"                
-      _ -> parens p
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="
 

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -7,6 +7,7 @@ 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 ()
@@ -204,12 +205,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) = (lbl, showJSON val)
+    where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
 
   readJSON  obj = head <$> readJSONs obj
   readJSONs obj = mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (RecordRow (LabelId lbl) value)
+                                      return (RecordRow (LabelId (rawIdentS lbl)) value)
 
 instance JSON rhs => JSON (TableRow rhs) where
   showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
@@ -242,20 +243,24 @@ instance JSON VarId where
     <|>        VarId <$> readJSON o
 
 instance JSON QualId where
-  showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
+  showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
   showJSON (Unqual n) = showJSON n
 
   readJSON o = do qualid <- readJSON o
                   let (mod, id) = span (/= '.') qualid
-                  return $ if null mod then Unqual id else Qual (ModId mod) id
+                  return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
+
+instance JSON RawIdent where
+  showJSON i = showJSON $ showRawIdent i
+  readJSON o = rawIdentS <$> readJSON o
 
 instance JSON Flags where
   -- flags are encoded directly as JSON records (i.e., objects):
-  showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
+  showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
 
   readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (lbl, value)
+                                      return (rawIdentS lbl, value)
 
 instance JSON FlagValue where
   -- flag values are encoded as basic JSON types:

src/compiler/GF/Grammar/Macros.hs

@@ -590,7 +590,7 @@ 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

src/compiler/GF/Infra/Ident.hs

@@ -13,18 +13,18 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- ** Identifiers
-              ModuleName(..), moduleNameS,
+  ModuleName(..), moduleNameS,
-	      Ident, ident2utf8, showIdent, prefixIdent,
+  Ident, ident2utf8, showIdent, prefixIdent,
-              -- *** Normal identifiers (returned by the parser)
+  -- *** Normal identifiers (returned by the parser)
-	      identS, identC, identW,
+  identS, identC, identW,
-              -- *** Special identifiers for internal use
+  -- *** Special identifiers for internal use
-              identV, identA, identAV,
+  identV, identA, identAV,
-	      argIdent, isArgIdent, getArgIndex,
+  argIdent, isArgIdent, getArgIndex,
-              varStr, varX, isWildIdent, varIndex,
+  varStr, varX, isWildIdent, varIndex,
-              -- *** Raw identifiers
+  -- *** Raw identifiers
-              RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-              isPrefixOf, showRawIdent
+  isPrefixOf, showRawIdent
-	     ) where
+) where
 
 import qualified Data.ByteString.UTF8 as UTF8
 import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -77,7 +77,6 @@ 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
@@ -88,6 +87,7 @@ 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,13 +95,14 @@ 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
 

src/compiler/GF/Infra/Option.hs

@@ -87,8 +87,7 @@ data Verbosity = Quiet | Normal | Verbose | Debug
 data Phase = Preproc | Convert | Compile | Link
   deriving (Show,Eq,Ord)
 
-data OutputFormat = FmtLPGF
+data OutputFormat = FmtPGFPretty
-                  | FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
                   | FmtJavaScript 
@@ -331,7 +330,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), lpgf, json, js, pgf_pretty, prolog, python, ...", -- gar,
+                  "Multiple concrete: pgf (default), 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") 
@@ -473,8 +472,7 @@ outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
 outputFormatsExpl = 
-    [(("lpgf",         FmtLPGF),"Linearisation-only PGF"),
+    [(("pgf_pretty",   FmtPGFPretty),"human-readable 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)"),

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.Error(ErrorT(..),Error(..))
+import Control.Monad.Except(ExceptT(..),runExceptT)
 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) (ErrorT Response IO) a
+type HM s a = StateT (Q,s) (ExceptT Response IO) a
 run :: HM s Response -> (Q,s) -> IO (s,Response)
-run m s = either bad ok =<< runErrorT (runStateT m s)
+run m s = either bad ok =<< runExceptT (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 -> ErrorT $ return $ Left e
+err e = StateT $ \ s -> ExceptT $ return $ Left e
 
 hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
 hmbracket_ pre post m =
     do s <- get
-       e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s
+       e <- liftIO $ bracket_ pre post $ runExceptT $ runStateT m s
        case e of
          Left resp -> err resp
          Right (a,s) -> do put s;return a
@@ -407,9 +407,6 @@ 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,14 +9,24 @@ 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
+instance JSON Fun where 
-instance JSON Param where showJSON (Param name rhs) = definition name rhs
+  showJSON (Fun   name typ) = signature  name typ
-instance JSON Oper  where showJSON (Oper  name rhs) = definition name rhs
+  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"
 
 signature  name typ = makeObj ["name".=name,"type".=typ]
 definition name rhs = makeObj ["name".=name,"rhs".=rhs]
@@ -26,12 +36,15 @@ 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,7 +1,11 @@
+## 1.3.0
+
+- Add completion support.
+
 ## 1.2.1
 
-- Remove deprecated pgf_print_expr_tuple
+- Remove deprecated `pgf_print_expr_tuple`.
-- Added an API for cloning expressions/types/literals
+- Added an API for cloning expressions/types/literals.
 
 ## 1.2.0
 

src/runtime/haskell-bind/PGF2.hsc

@@ -43,30 +43,28 @@ 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
@@ -974,6 +972,67 @@ 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 $

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

@@ -256,6 +256,7 @@ data PgfApplication
 data PgfConcr
 type PgfExpr = Ptr ()
 data PgfExprProb
+data PgfTokenProb
 data PgfExprParser
 data PgfFullFormEntry
 data PgfMorphoCallback
@@ -422,6 +423,9 @@ 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.2.1
+version: 1.3.0
 synopsis: Bindings to the C version of the PGF runtime
 description:
   GF, Grammatical Framework, is a programming language for multilingual grammar applications.
@@ -9,8 +9,7 @@ homepage: https://www.grammaticalframework.org
 license: LGPL-3
 license-file: LICENSE
 author: Krasimir Angelov
-maintainer: kr.angelov@gmail.com
+category: Natural Language Processing
-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 (inlinePerformIO)
+import Data.ByteString.Internal (accursedUnutterablePerformIO)
 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 -> inlinePerformIO $ do
+unsafeLiftIO f =  Builder $ \ k buf -> accursedUnutterablePerformIO $ 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.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
+    return . B.accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
 {- INLINE getPtr -}
 
 ------------------------------------------------------------------------

src/runtime/haskell/LPGF.hs

@@ -1,368 +0,0 @@
-{-# 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.Error
+import Control.Monad.Except
 import Text.PrettyPrint
 
 -----------------------------------------------------

src/runtime/haskell/pgf.cabal

@@ -1,5 +1,5 @@
 name: pgf
-version: 3.10
+version: 3.10.1-git
 
 cabal-version: >= 1.20
 build-type: Simple
@@ -9,20 +9,21 @@ 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
-maintainer: Thomas Hallgren
+tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC==8.4.4
-tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2
 
-Library
+library
-  default-language:    Haskell2010
+  default-language: Haskell2010
-  build-depends: base >= 4.6 && <5,
+  build-depends:
-                 array,
+    array,
-                 containers,
+    base >= 4.6 && <5,
-                 bytestring,
+    bytestring,
-                 utf8-string,
+    containers,
-                 random,
+    -- exceptions,
-                 pretty,
+    ghc-prim,
-                 mtl,
+    mtl,
-                 exceptions
+    pretty,
+    random,
+    utf8-string
 
   other-modules:
     -- not really part of GF but I have changed the original binary library
@@ -37,7 +38,6 @@ 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,29 +151,37 @@ getFile get path =
 cpgfMain qsem command (t,(pgf,pc)) =
   case command of
     "c-parse"       -> withQSem qsem $
-                       out t=<< join (parse # input % start % limit % treeopts)
+                       out t=<< join (parse # input % cat % start % limit % treeopts)
     "c-parseToChart"-> withQSem qsem $
-                       out t=<< join (parseToChart # input % limit)
+                       out t=<< join (parseToChart # input % cat % 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 % to % start % limit%treeopts)
+                       out t=<<join(trans # input % cat % 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 % to
+    "c-wordforword" -> out t =<< wordforword # input % cat % to
     _               -> badRequest "Unknown command" command
   where
     flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
                         performGC
                         return $ showJSON ()
 
-    cat = C.startCat pgf
+    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
+
     langs = C.languages pgf
 
     grammar = showJSON $ makeObj
@@ -184,8 +192,8 @@ cpgfMain qsem command (t,(pgf,pc)) =
       where
         languages = [makeObj ["name".= l] | (l,_)<-Map.toList langs]
 
-    parse input@((from,_),_) start mlimit (trie,json) =
+    parse input@((from,_),_) cat start mlimit (trie,json) =
-        do r <- parse' start mlimit input
+        do r <- parse' cat start mlimit input
            return $ showJSON [makeObj ("from".=from:jsonParseResult json r)]
 
     jsonParseResult json = either bad good
@@ -195,7 +203,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
         tp (tree,prob) = makeObj (addTree json tree++["prob".=prob])
 
     -- Without caching parse results:
-    parse' start mlimit ((from,concr),input) =
+    parse' cat 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)
@@ -221,7 +229,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                              -- remove unused parse results after 2 minutes
 -}
 
-    parseToChart ((from,concr),input) mlimit =
+    parseToChart ((from,concr),input) cat 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)
@@ -262,8 +270,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,_),_) to start mlimit (trie,jsontree) =
+    trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
-      do parses <- parse' start mlimit input
+      do parses <- parse' cat start mlimit input
          return $
            showJSON [ makeObj ["from".=from,
                                "translations".= jsonParses parses]]
@@ -297,7 +305,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                       _              -> id)
                                      (C.lookupCohorts concr input)]
 
-    wordforword input@((from,_),_) = jsonWFW from . wordforword' input
+    wordforword input@((from,_),_) cat = jsonWFW from . wordforword' input cat
 
     jsonWFW from rs =
       showJSON
@@ -307,7 +315,7 @@ cpgfMain qsem command (t,(pgf,pc)) =
                                         [makeObj["to".=to,"text".=text]
                                          | (to,text)<-rs]]]]]
 
-    wordforword' inp@((from,concr),input) (tos,unlex) =
+    wordforword' inp@((from,concr),input) cat (tos,unlex) =
         [(to,unlex . unwords $ map (lin_word' c) pws)
          |let pws=map parse_word' (words input),(to,c)<-tos]
       where
@@ -1024,6 +1032,7 @@ 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,9 +4,16 @@ 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

stack-ghc8.0.2.yaml

@@ -1 +1,7 @@
 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,3 +4,9 @@ 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,3 +2,9 @@ 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,3 +4,9 @@ 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,3 +7,8 @@ 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,5 +1,6 @@
 # This default stack file is a copy of stack-ghc8.6.5.yaml
-# But committing a symlink is probably a bad idea, so it's a real copy
+# But committing a symlink can be problematic on Windows, so it's a real copy.
+# See: https://github.com/GrammaticalFramework/gf-core/pull/106
 
 resolver: lts-14.27 # ghc 8.6.5
 
@@ -7,3 +8,9 @@ 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

testsuite/canonical/.gitignore

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

testsuite/canonical/gold/FoodsFin.gf

@@ -0,0 +1,102 @@
+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

@@ -0,0 +1,29 @@
+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

@@ -0,0 +1,251 @@
+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

@@ -0,0 +1,16 @@
+-- (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/LexFoodsFin.gf

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

testsuite/canonical/grammars/Phrasebook.gf

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

testsuite/canonical/grammars/PhrasebookBul.gf

@@ -0,0 +1,31 @@
+--# -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

@@ -0,0 +1,14 @@
+--# -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

@@ -0,0 +1,36 @@
+#!/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

@@ -0,0 +1,54 @@
+#!/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

@@ -0,0 +1,48 @@
+--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,7 +1,9 @@
 
 
-testsuite/compiler/check/lincat-types/TestCnc.gf:3:
+testsuite/compiler/check/lincat-types/TestCnc.gf:
-  Happened in linearization type of S
+   testsuite/compiler/check/lincat-types/TestCnc.gf:3:
-    type of PTrue
+     Happened in linearization type of S
-   expected: Type
+       type of PTrue
-   inferred: PBool
+      expected: Type
+      inferred: Predef.PBool
+      

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

@@ -1,6 +1,3 @@
-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 ;
@@ -12,16 +9,23 @@ abstract lins {
 }
 concrete linsCnc {
   productions
-    C1 -> F2[]
+    C1 -> F4[]
   lindefs
-    C0 -> F0
+    C0 -> F0[CVar]
-    C1 -> F1
+    C1 -> F2[CVar]
+  linrefs
+    CVar -> F1[C0]
+    CVar -> F3[C1]
   lin
-    F0 := (S0) [lindef C]
+    F0 := (S2) ['lindef C']
-    F1 := () [lindef Nat]
+    F1 := (S1) ['lindef C']
-    F2 := () [zero]
+    F2 := () ['lindef Nat']
+    F3 := (S0) ['lindef Nat']
+    F4 := () [zero]
   sequences
-    S0 := {0,0}
+    S0 :=
+    S1 := <0,0>
+    S2 := {0,0}
   categories
     C := range  [C0 .. C0]
          labels ["s"]
@@ -33,7 +37,5 @@ concrete linsCnc {
            labels []
     String := range  [CString .. CString]
               labels ["s"]
-    __gfVar := range  [CVar .. CVar]
-               labels [""]
   printnames
 }

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

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

testsuite/compiler/check/strMatch/Prelude.gf

@@ -0,0 +1,161 @@
+--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

@@ -0,0 +1 @@
+

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

@@ -0,0 +1,15 @@
+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 +1,3 @@
-fun f : (Int -> Int) -> Int -> Int
+fun f : (Int -> Int) -> Int -> Int ;
+Probability: 1.0
+

testsuite/compiler/typecheck/abstract/LitAbs.gf

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

testsuite/compiler/typecheck/abstract/LitAbs.gfs

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

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

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

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

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

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

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

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

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

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

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

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

@@ -1,5 +1,9 @@
 
 
-testsuite/compiler/typecheck/concrete/A.gf:5:
+testsuite/compiler/typecheck/concrete/A.gf:
-  Happened in operation silly
+   testsuite/compiler/typecheck/concrete/A.gf:5:
-   A function type is expected for a_Det instead of type Str
+     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/libraries/exx-resource.gfs

@@ -1,226 +0,0 @@
-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

@@ -1,239 +0,0 @@
-# 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

@@ -1,184 +0,0 @@
-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

@@ -1,13 +0,0 @@
---# -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

@@ -1,13 +0,0 @@
---# -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

@@ -1,15 +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 ;
-}

testsuite/lpgf/foods/Foods.treebank

@@ -1,185 +0,0 @@
-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

@@ -1,5 +0,0 @@
-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

@@ -1,77 +0,0 @@
--- (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

@@ -1,21 +0,0 @@
-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

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

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

testsuite/lpgf/foods/FoodsChi.gf

@@ -1,56 +0,0 @@
-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

@@ -1,35 +0,0 @@
--- (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

@@ -1,58 +0,0 @@
--- (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

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

@@ -1,48 +0,0 @@
--- (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" ;
-}
-    

testsuite/lpgf/foods/FoodsFre.gf

@@ -1,31 +0,0 @@
-
-concrete FoodsFre of Foods = open SyntaxFre, ParadigmsFre in {
-
-	flags coding = utf8 ;
-	
-	lincat
-		Comment = Utt ;
-		Item = NP ;
-		Kind = CN ;
-		Quality = AP ;
-	
-	lin
-		Pred item quality = mkUtt (mkCl item quality) ;
-		This kind = mkNP this_QuantSg kind ;
-		That kind = mkNP that_QuantSg kind ;
-		These kind = mkNP these_QuantPl kind ;
-		Those kind = mkNP those_QuantPl kind ;
-		Mod quality kind = mkCN quality kind ;
-		Very quality = mkAP very_AdA quality ;
-		
-		Wine = mkCN (mkN "vin" masculine) ;
-		Pizza = mkCN (mkN "pizza" feminine) ;
-		Cheese = mkCN (mkN "fromage" masculine) ;
-		Fish = mkCN (mkN "poisson" masculine) ;
-		Fresh = mkAP (mkA "frais" "fraîche" "frais" "fraîchement") ;
-		Warm = mkAP (mkA "chaud") ;
-		Italian = mkAP (mkA "italien") ;
-		Expensive = mkAP (mkA "cher") ;
-		Delicious = mkAP (mkA "délicieux") ;
-		Boring = mkAP (mkA "ennuyeux") ;
-	}

testsuite/lpgf/foods/FoodsGer.gf

@@ -1,6 +0,0 @@
-
--- (c) 2009 Aarne Ranta under LGPL
-
-concrete FoodsGer of Foods = FoodsI with 
-  (Syntax = SyntaxGer),
-  (LexFoods = LexFoodsGer) ;

testsuite/lpgf/foods/FoodsGla.gf

@@ -1,67 +0,0 @@
---# -coding=latin1
-concrete FoodsGla of Foods = open MutationsGla, CharactersGla, Prelude in {
-	param Gender = Masc|Fem ;
-	param Number = Sg|Pl ;
-	param Breadth = Broad|Slender|NoBreadth ;
-	param Beginning = Bcgmp|Other ;
-	
-	lincat Comment = Str;
-	lin Pred item quality = "tha" ++ item ++ quality.s!Sg!Unmutated ;
-
-	lincat Item = Str;
-	lin
-		This kind = (addArticleSg kind) ++ "seo" ;
-		That kind = (addArticleSg kind) ++ "sin";
-		These kind = (addArticlePl kind) ++ "seo" ;
-		Those kind = (addArticlePl kind) ++ "sin" ;
-	oper addArticleSg : {s : Number => Mutation => Str; g : Gender} -> Str =
-						  \kind -> case kind.g of { Masc => "an" ++ kind.s!Sg!PrefixT; Fem => "a'" ++ kind.s!Sg!Lenition1DNTLS } ;
-	oper addArticlePl : {s : Number => Mutation => Str; g : Gender} -> Str =
-					    \kind -> "na" ++ kind.s!Pl!PrefixH ;
-	
-	oper Noun : Type = {s : Number => Mutation => Str; g : Gender; pe : Breadth; beginning: Beginning; };
-	lincat Kind = Noun;
-	lin
-		Mod quality kind = {
-			s = table{
-					Sg => table{mutation => kind.s!Sg!mutation ++ case kind.g of {Masc => quality.s!Sg!Unmutated; Fem => quality.s!Sg!Lenition1} };
-					Pl => table{mutation => kind.s!Pl!mutation ++ case kind.pe of {Slender => quality.s!Pl!Lenition1; _ => quality.s!Pl!Unmutated} }
-			};
-			g = kind.g;
-			pe = kind.pe;
-			beginning = kind.beginning
-		} ;
-		Wine = makeNoun "fìon" "fìontan" Masc ;
-		Cheese = makeNoun "càise" "càisean" Masc ;
-		Fish = makeNoun "iasg" "èisg" Masc ;
-		Pizza = makeNoun "pizza" "pizzathan" Masc ;
-	oper makeNoun : Str -> Str -> Gender -> Noun = \sg,pl,g -> {
-		s = table{Sg => (mutate sg); Pl => (mutate pl)};
-		g = g;
-		pe = pe;
-		beginning = Bcgmp
-	}
-	where {
-		pe : Breadth = case pl of {
-			_ + v@(#broadVowel) + c@(#consonant*) + #consonant => Broad;
-			_ + v@(#slenderVowel) + c@(#consonant*) + #consonant => Slender;
-			_ => NoBreadth
-		}
-	};
-
-	oper Adjective : Type = {s : Number => Mutation => Str; sVery : Number => Str};
-	lincat Quality = Adjective;
-	lin
-		Very quality = {s=table{number => table{_ => quality.sVery!number}}; sVery=quality.sVery } ;
-		Fresh = makeAdjective "úr" "ùra" ;
-		Warm = makeAdjective "blàth" "blàtha" ;
-		Italian = makeAdjective "Eadailteach" "Eadailteach" ;
-		Expensive = makeAdjective "daor" "daora" ;
-		Delicious = makeAdjective "blasta" "blasta" ;
-		Boring = makeAdjective "leamh" "leamha" ;
-	oper makeAdjective : Str -> Str -> Adjective =
-		\sg,pl -> {
-					s=table{Sg => (mutate sg); Pl => (mutate pl)};
-					sVery=table{Sg => "glè"++(lenition1dntls sg); Pl => "glè"++(lenition1dntls pl)}
-				  } ;
-}

testsuite/lpgf/foods/FoodsGle.gf

@@ -1,60 +0,0 @@
---# -coding=latin1
-concrete FoodsGle of Foods = open MutationsGle, CharactersGle in {
-	param Gender = Masc|Fem ;
-	param Number = Sg|Pl ;
-	param Breadth = Broad|Slender|NoBreadth ;
-	
-	lincat Comment = Str;
-	lin Pred item quality = "tá" ++ item ++ quality.s!Sg!Unmutated ;
-
-	lincat Item = Str;
-	lin
-		This kind = (addArticleSg kind) ++ "seo" ;
-		That kind = (addArticleSg kind) ++ "sin";
-		These kind = (addArticlePl kind) ++ "seo" ;
-		Those kind = (addArticlePl kind) ++ "sin" ;
-	oper addArticleSg : {s : Number => Mutation => Str; g : Gender} -> Str =
-					    \kind -> "an" ++ case kind.g of { Masc => kind.s!Sg!PrefixT; Fem => kind.s!Sg!Lenition1DNTLS } ;
-	oper addArticlePl : {s : Number => Mutation => Str; g : Gender} -> Str =
-					    \kind -> "na" ++ kind.s!Pl!PrefixH ;
-	
-	lincat Kind = {s : Number => Mutation => Str; g : Gender; pe : Breadth} ;
-	lin
-		Mod quality kind = {
-			s = table{
-					Sg => table{mutation => kind.s!Sg!mutation ++ case kind.g of {Masc => quality.s!Sg!Unmutated; Fem => quality.s!Sg!Lenition1} };
-					Pl => table{mutation => kind.s!Pl!mutation ++ case kind.pe of {Slender => quality.s!Pl!Lenition1; _ => quality.s!Pl!Unmutated} }
-			};
-			g = kind.g;
-			pe = kind.pe
-		} ;
-		Wine = makeNoun "fíon" "fíonta" Masc ;
-		Cheese = makeNoun "cáis" "cáiseanna" Fem ;
-		Fish = makeNoun "iasc" "éisc" Masc ;
-		Pizza = makeNoun "píotsa" "píotsaí" Masc ;
-	oper makeNoun : Str -> Str -> Gender -> {s : Number => Mutation => Str; g : Gender; pe : Breadth} =
-		\sg,pl,g -> {
-						s = table{Sg => (mutate sg); Pl => (mutate pl)};
-						g = g;
-						pe = case pl of {
-							_ + v@(#broadVowel) + c@(#consonant*) + #consonant => Broad;
-							_ + v@(#slenderVowel) + c@(#consonant*) + #consonant => Slender;
-							_ => NoBreadth
-						}
-					} ;
-
-	lincat Quality = {s : Number => Mutation => Str; sVery : Number => Str} ;
-	lin
-		Very quality = {s=table{number => table{_ => quality.sVery!number}}; sVery=quality.sVery } ;
-		Fresh = makeAdjective "úr" "úra" ;
-		Warm = makeAdjective "te" "te" ;
-		Italian = makeAdjective "Iodálach" "Iodálacha" ;
-		Expensive = makeAdjective "daor" "daora" ;
-		Delicious = makeAdjective "blasta" "blasta" ;
-		Boring = makeAdjective "leamh" "leamha" ;
-	oper makeAdjective : Str -> Str -> {s : Number => Mutation => Str; sVery : Number => Str} =
-		\sg,pl -> {
-					s=table{Sg => (mutate sg); Pl => (mutate pl)};
-					sVery=table{Sg => "an-"+(lenition1dntls sg); Pl => "an-"+(lenition1dntls pl)}
-				  } ;
-}

testsuite/lpgf/foods/FoodsHeb.gf

@@ -1,107 +0,0 @@
-
---(c) 2009 Dana Dannells
--- Licensed under LGPL
-
-concrete FoodsHeb of Foods = open Prelude in {
-  
-  flags coding=utf8 ;
-
-    lincat
-      Comment = SS ;
-      Quality = {s: Number => Species => Gender =>  Str} ;  
-      Kind = {s : Number => Species => Str ; g : Gender ; mod : Modified} ; 
-      Item = {s : Str ; g : Gender ; n : Number ; sp : Species ; mod : Modified} ; 
-  
- 
-    lin
-      Pred item quality = ss (item.s ++ quality.s ! item.n ! Indef ! item.g ) ; 
-      This  = det Sg Def "הזה" "הזאת"; 
-      That  = det Sg Def "ההוא" "ההיא" ; 
-      These = det Pl Def "האלה" "האלה" ; 
-      Those = det Pl Def "ההם" "ההן" ; 
-      Mod quality kind = {
-	s = \\n,sp => kind.s ! n ! sp ++ quality.s ! n ! sp ! kind.g;
-	g = kind.g ;
-	mod = T
-	} ;     
-      Wine = regNoun "יין" "יינות" Masc ; 
-      Cheese = regNoun "גבינה" "גבינות" Fem ;  
-      Fish = regNoun "דג" "דגים" Masc ; 
-      Pizza = regNoun "פיצה" "פיצות" Fem ; 
-      Very qual = {s = \\g,n,sp => "מאוד" ++  qual.s ! g ! n ! sp} ;
-      Fresh = regAdj "טרי" ; 
-      Warm = regAdj "חם" ;
-      Italian = regAdj2 "איטלקי" ;
-      Expensive = regAdj "יקר" ; 
-      Delicious = regAdj "טעים" ; 
-      Boring = regAdj2 "משעמם"; 
-
-    param 
-      Number = Sg | Pl ;
-      Gender = Masc | Fem ;
-      Species = Def | Indef ;  
-      Modified = T | F ;
-
-    oper
-	Noun : Type = {s : Number => Species => Str ; g : Gender ; mod : Modified } ;
-  	Adj : Type = {s : Number => Species => Gender => Str} ;
-
-      det : Number -> Species -> Str -> Str -> Noun -> 
-	{s : Str ; g :Gender ; n : Number ; sp : Species ; mod : Modified} = 
-        \n,sp,m,f,cn -> {
-	  s = case cn.mod of { _ => cn.s ! n ! sp ++ case cn.g of {Masc => m ; Fem  => f} };
-	  g = cn.g ; 
-          n = n ;
-	  sp = sp ;
-	  mod = cn.mod
-        } ;
-      
-	noun : (gvina,hagvina,gvinot,hagvinot : Str) ->  Gender -> Noun =  
-      		\gvina,hagvina,gvinot,hagvinot,g -> {
-        	s = table {
-          		Sg  => table {
-             			Indef => gvina ;
-             			Def =>  hagvina 
-            		} ;
-          		Pl => table {
-             			Indef => gvinot ;
-             			Def => hagvinot  
-            		} 
-       	  	} ;
-        	g = g ;
-		mod = F 
-      } ;
-
-	regNoun : Str -> Str -> Gender -> Noun = 
-	        \gvina,gvinot, g -> 
-		noun gvina (defH gvina) gvinot (defH gvinot) g ; 
-
-      defH : Str -> Str = \cn ->
-	case cn of {_ => "ה" + cn};	
-
-      replaceLastLetter : Str -> Str = \c ->
-	 case c of {"ף" => "פ" ; "ם" => "מ" ; "ן" => "נ" ; "ץ" => "צ" ; "ך" => "כ"; _ => c} ;
-	      
-      adjective : (_,_,_,_ : Str) -> Adj = 
-       \tov,tova,tovim,tovot -> {
-        s = table {
-          Sg => table { 
-			Indef => table { Masc => tov ; Fem => tova } ; 
-			Def => table { Masc => defH tov ; Fem => defH tova }  
-            		} ; 
-          Pl => table { 
-			Indef => table {Masc => tovim ; Fem  => tovot } ; 
-			Def => table { Masc => defH tovim ; Fem  => defH tovot }  
-            		}
-	}
-      } ;
-    
-      regAdj : Str -> Adj = \tov ->
-	case tov of { to + c@? =>
-	adjective tov (to + replaceLastLetter (c) + "ה" ) (to + replaceLastLetter (c) +"ים" ) (to + replaceLastLetter (c) + "ות" )};	 
-     
-     regAdj2 : Str -> Adj = \italki ->
- 	case italki of { italk+ c@? => 
-    adjective italki (italk + replaceLastLetter (c)  +"ת" )  (italk + replaceLastLetter (c)+ "ים" ) (italk + replaceLastLetter (c)  + "ות" )};
-
-}  -- FoodsHeb  

testsuite/lpgf/foods/FoodsHin.gf

@@ -1,75 +0,0 @@
--- (c) 2010 Vikash Rauniyar under LGPL
-
-concrete FoodsHin of Foods = {
-
-  flags coding=utf8 ;
-
-  param
-    Gender = Masc | Fem ;
-    Number = Sg | Pl ;
-  lincat
-    Comment = {s : Str} ;
-    Item    = {s : Str ; g : Gender ; n : Number} ;
-    Kind    = {s : Number => Str ; g : Gender} ;
-    Quality = {s : Gender => Number => Str} ;
-  lin
-    Pred item quality = {
-      s = item.s ++ quality.s ! item.g ! item.n ++ copula item.n
-      } ;
-    This kind = {s = "यह" ++ kind.s ! Sg ; g = kind.g ; n = Sg} ;
-    That kind = {s = "वह" ++ kind.s ! Sg ; g = kind.g ; n = Sg} ;
-    These kind = {s = "ये" ++ kind.s ! Pl ; g = kind.g ; n = Pl} ;
-    Those kind = {s = "वे" ++ kind.s ! Pl ; g = kind.g ; n = Pl} ;
-    Mod quality kind = {
-      s = \\n => quality.s ! kind.g ! n ++ kind.s ! n ; 
-      g = kind.g
-      } ;
-    Wine = regN "मदिरा" ;
-    Cheese = regN "पनीर" ;
-    Fish = regN "मछली" ;
-    Pizza = regN "पिज़्ज़ा" ;
-    Very quality = {s = \\g,n => "अति" ++ quality.s ! g ! n} ;
-    Fresh = regAdj "ताज़ा" ;
-    Warm = regAdj "गरम" ;
-    Italian = regAdj "इटली" ; 
-    Expensive = regAdj "बहुमूल्य" ;
-    Delicious = regAdj "स्वादिष्ट" ;
-    Boring = regAdj "अरुचिकर" ;
-
-  oper
-    mkN : Str -> Str -> Gender -> {s : Number => Str ; g : Gender} = 
-      \s,p,g -> {
-        s = table {
-          Sg => s ;
-          Pl => p
-          } ;
-        g = g
-      } ;
-
-    regN : Str -> {s : Number => Str ; g : Gender} = \s -> case s of {
-      lark + "ा" => mkN s (lark + "े") Masc ;
-      lark + "ी" => mkN s (lark + "ीयँा") Fem ;
-      _           => mkN s s Masc 
-      } ;
-
-    mkAdj : Str -> Str -> Str -> {s : Gender => Number => Str} = \ms,mp,f -> {
-      s = table {
-        Masc => table {
-          Sg => ms ;
-          Pl => mp
-          } ;
-        Fem  => \\_ => f
-        }
-      } ;
-
-    regAdj : Str -> {s : Gender => Number => Str} = \a -> case a of {
-      acch + "ा" => mkAdj a (acch + "े") (acch + "ी") ;
-      _          => mkAdj a a a
-      } ;
-
-    copula : Number -> Str = \n -> case n of {
-      Sg => "है" ;
-      Pl => "हैं"
-      } ;
-
-  }

testsuite/lpgf/foods/FoodsIce.gf

@@ -1,83 +0,0 @@
-
--- (c) 2009 Martha Dis Brandt under LGPL
-
-concrete FoodsIce of Foods = open Prelude in {
-
-  flags coding=utf8;
-
-  lincat
-    Comment = SS ; 
-    Quality = {s : Gender => Number => Defin => Str} ; 
-    Kind = {s : Number => Str ; g : Gender} ; 
-    Item = {s : Str ; g : Gender ; n : Number} ; 
-
-  lin
-    Pred item quality =  ss (item.s ++ copula item.n ++ quality.s ! item.g ! item.n ! Ind) ;
-         This, That  = det Sg "þessi"   "þessi"  "þetta" ;
-         These, Those = det Pl "þessir" "þessar" "þessi" ;
-    Mod quality kind = { s = \\n => quality.s ! kind.g ! n ! Def ++ kind.s ! n ; g = kind.g } ;
-         Wine = noun "vín" "vín" Neutr ;
-         Cheese = noun "ostur" "ostar" Masc ; 
-         Fish = noun "fiskur" "fiskar" Masc ; 
-         -- the word "pizza" is more commonly used in Iceland, but "flatbaka" is the Icelandic word for it
-         Pizza = noun "flatbaka" "flatbökur" Fem ;
-    Very qual = {s = \\g,n,defOrInd => "mjög" ++ qual.s ! g ! n ! defOrInd } ;
-         Fresh = regAdj "ferskur" ;
-         Warm = regAdj "heitur" ;
-         Boring = regAdj "leiðinlegur" ;
-         -- the order of the given adj forms is: mSg fSg nSg mPl fPl nPl mSgDef f/nSgDef _PlDef
-         Italian = adjective "ítalskur" "ítölsk" "ítalskt" "ítalskir" "ítalskar" "ítölsk" "ítalski" "ítalska" "ítalsku" ;
-         Expensive = adjective "dýr" "dýr" "dýrt" "dýrir" "dýrar" "dýr" "dýri" "dýra" "dýru" ; 
-         Delicious = adjective "ljúffengur" "ljúffeng" "ljúffengt" "ljúffengir" "ljúffengar" "ljúffeng" "ljúffengi" "ljúffenga" "ljúffengu" ;
-
-  param
-    Number = Sg | Pl ;
-    Gender = Masc | Fem | Neutr ;
-    Defin = Ind | Def ;
-
-  oper
-    det : Number -> Str -> Str -> Str -> {s : Number => Str ; g : Gender} -> 
-        {s : Str ; g : Gender ; n : Number} = 
-      \n,masc,fem,neutr,cn -> {
-        s = case cn.g of {Masc => masc ; Fem => fem; Neutr => neutr } ++ cn.s ! n ;
-        g = cn.g ;
-        n = n
-      } ;
-
-    noun : Str -> Str -> Gender -> {s : Number => Str ; g : Gender} = 
-      \man,men,g -> {
-        s = table {
-          Sg => man ;
-          Pl => men 
-          } ;
-        g = g
-      } ;
-
-    adjective : (x1,_,_,_,_,_,_,_,x9 : Str) -> {s : Gender => Number => Defin => Str} =
-      \ferskur,fersk,ferskt,ferskir,ferskar,fersk_pl,ferski,ferska,fersku -> {
-         s = \\g,n,t => case <g,n,t> of {
-            < Masc, Sg, Ind > => ferskur ;
-            < Masc, Pl, Ind > => ferskir ;
-            < Fem, Sg, Ind > => fersk ;
-            < Fem, Pl, Ind > => ferskar ;
-            < Neutr, Sg, Ind > => ferskt ;
-            < Neutr, Pl, Ind > => fersk_pl;
-            < Masc, Sg, Def > => ferski ;
-            < Fem, Sg, Def > | < Neutr, Sg, Def > => ferska ;
-            < _ , Pl, Def > => fersku 
-            }
-          } ;
-
-    regAdj : Str -> {s : Gender => Number => Defin => Str} = \ferskur ->
-      let fersk = Predef.tk 2 ferskur
-      in adjective
-        ferskur fersk (fersk + "t")
-        (fersk + "ir") (fersk + "ar") fersk
-        (fersk + "i") (fersk + "a") (fersk + "u") ;
-
-    copula : Number -> Str = 
-      \n -> case n of {
-        Sg => "er" ;
-        Pl => "eru"
-        } ;
-}

testsuite/lpgf/foods/FoodsIta.gf

@@ -1,7 +0,0 @@
-
--- (c) 2009 Aarne Ranta under LGPL
-
-concrete FoodsIta of Foods = FoodsI with 
-  (Syntax = SyntaxIta),
-  (LexFoods = LexFoodsIta) ;
-