remove RConcrete

gf.cabal

@@ -63,128 +63,38 @@ flag network-uri
    description: Get Network.URI from the network-uri package
    default: True
 
---flag new-comp
---  Description: Make -new-comp the default
---  Default:     True
-
-flag c-runtime
-  Description: Include functionality from the C run-time library (which must be installed already)
-  Default: False
-
-library
-  default-language: Haskell2010
-  build-depends:
-    -- GHC 8.0.2 to GHC 8.10.4
-    array >= 0.5.1 && < 0.6,
-    base >= 4.9.1 && < 4.15,
-    bytestring >= 0.10.8 && < 0.11,
-    containers >= 0.5.7 && < 0.7,
-    exceptions >= 0.8.3 && < 0.11,
-    ghc-prim >= 0.5.0 && < 0.7,
-    mtl >= 2.2.1 && < 2.3,
-    pretty >= 1.1.3 && < 1.2,
-    random >= 1.1 && < 1.3,
-    utf8-string >= 1.0.1.1 && < 1.1,
-    -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
-    transformers-compat >= 0.5.1.4 && < 0.7
-
-  if impl(ghc<8.0)
-    build-depends:
-      fail >= 4.9.0 && < 4.10
-
-  hs-source-dirs: src/runtime/haskell
+executable gf
+  hs-source-dirs: src/programs, src/compiler
+  main-is: gf-main.hs
+  default-language:    Haskell2010
+  build-depends: pgf2,
+                 base >= 4.6 && <5,
+                 array,
+                 containers,
+                 bytestring,
+                 utf8-string,
+                 random,
+                 pretty,
+                 mtl,
+                 exceptions,
+                 ghc-prim,
+                 filepath, directory>=1.2, time,
+                 process, haskeline, parallel>=3, json
+  ghc-options: -threaded
 
   other-modules:
-    -- not really part of GF but I have changed the original binary library
-    -- and we have to keep the copy for now.
-    Data.Binary
-    Data.Binary.Put
-    Data.Binary.Get
-    Data.Binary.Builder
-    Data.Binary.IEEE754
-
---ghc-options: -fwarn-unused-imports
---if impl(ghc>=7.8)
---  ghc-options: +RTS -A20M -RTS
-  ghc-prof-options: -fprof-auto
-
-  exposed-modules:
-    PGF
-    PGF.Internal
-    PGF.Haskell
-
-  other-modules:
-    PGF.Data
-    PGF.Macros
-    PGF.Binary
-    PGF.Optimize
-    PGF.Printer
-    PGF.CId
-    PGF.Expr
-    PGF.Generate
-    PGF.Linearize
-    PGF.Morphology
-    PGF.Paraphrase
-    PGF.Parse
-    PGF.Probabilistic
-    PGF.SortTop
-    PGF.Tree
-    PGF.Type
-    PGF.TypeCheck
-    PGF.Forest
-    PGF.TrieMap
-    PGF.VisualizeTree
-    PGF.ByteCode
-    PGF.OldBinary
-    PGF.Utilities
-
-  if flag(c-runtime)
-    exposed-modules: PGF2
-    other-modules:
-      PGF2.FFI
-      PGF2.Expr
-      PGF2.Type
-      GF.Interactive2
-      GF.Command.Commands2
-    hs-source-dirs: src/runtime/haskell-bind
-    build-tools: hsc2hs
-    extra-libraries: pgf gu
-    c-sources: src/runtime/haskell-bind/utils.c
-    cc-options: -std=c99
-
----- GF compiler as a library:
-
-  build-depends:
-    directory >= 1.3.0 && < 1.4,
-    filepath >= 1.4.1 && < 1.5,
-    haskeline >= 0.7.3 && < 0.9,
-    json >= 0.9.1 && < 0.11,
-    parallel >= 3.2.1.1 && < 3.3,
-    process >= 1.4.3 && < 1.7,
-    time >= 1.6.0 && < 1.10
-
-  hs-source-dirs: src/compiler
-  exposed-modules:
     GF
     GF.Support
     GF.Text.Pretty
     GF.Text.Lexing
     GF.Grammar.Canonical
 
-  other-modules:
-    GF.Main
-    GF.Compiler
-    GF.Interactive
+    GF.Main GF.Compiler GF.Interactive
 
-    GF.Compile
-    GF.CompileInParallel
-    GF.CompileOne
-    GF.Compile.GetGrammar
+    GF.Compile GF.CompileInParallel GF.CompileOne  GF.Compile.GetGrammar
     GF.Grammar
 
-    GF.Data.Operations
-    GF.Infra.Option
-    GF.Infra.UseIO
+    GF.Data.Operations GF.Infra.Option GF.Infra.UseIO
 
     GF.Command.Abstract
     GF.Command.CommandInfo
@@ -199,9 +109,9 @@ library
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Concrete
     GF.Compile.Compute.Predef
     GF.Compile.Compute.Value
+    GF.Compile.Compute.Concrete
     GF.Compile.ExampleBased
     GF.Compile.Export
     GF.Compile.GenerateBC
@@ -209,16 +119,14 @@ library
     GF.Compile.GrammarToPGF
     GF.Compile.Multi
     GF.Compile.Optimize
+    GF.Compile.OptimizePGF
     GF.Compile.PGFtoHaskell
     GF.Compile.PGFtoJava
     GF.Haskell
     GF.Compile.ConcreteToHaskell
     GF.Compile.GrammarToCanonical
     GF.Grammar.CanonicalJSON
-    GF.Compile.PGFtoJS
     GF.Compile.PGFtoJSON
-    GF.Compile.PGFtoProlog
-    GF.Compile.PGFtoPython
     GF.Compile.ReadFiles
     GF.Compile.Rename
     GF.Compile.SubExOpt
@@ -285,64 +193,20 @@ library
     GF.System.Directory
     GF.System.Process
     GF.System.Signal
+    GF.System.NoSignal
     GF.Text.Clitics
     GF.Text.Coding
+    GF.Text.Lexing
     GF.Text.Transliterations
     Paths_gf
-
-  if flag(c-runtime)
-    cpp-options: -DC_RUNTIME
-
-  if flag(server)
-    build-depends:
-      cgi >= 3001.3.0.2 && < 3001.6,
-      httpd-shed >= 0.4.0 && < 0.5,
-      network>=2.3 && <2.7
-    if flag(network-uri)
-      build-depends:
-        network-uri >= 2.6.1.0 && < 2.7,
-        network>=2.6 && <2.7
-    else
-      build-depends:
-        network >= 2.5 && <2.6
-
-    cpp-options: -DSERVER_MODE
-    other-modules:
-      GF.Server
-      PGFService
-      RunHTTP
-      SimpleEditor.Convert
-      SimpleEditor.JSON
-      SimpleEditor.Syntax
-      URLEncoding
-      CGI
-      CGIUtils
-      Cache
-      Fold
-      ExampleDemo
-      ExampleService
-    hs-source-dirs:
-      src/server
-      src/server/transfer
-      src/example-based
-
-  if flag(interrupt)
-    cpp-options: -DUSE_INTERRUPT
-    other-modules: GF.System.UseSignal
-  else
-    other-modules: GF.System.NoSignal
-
-  if impl(ghc>=7.8)
-    build-tools:
-      happy>=1.19,
-      alex>=3.1
---  ghc-options: +RTS -A20M -RTS
-  else
-    build-tools:
-      happy,
-      alex>=3
-
-  ghc-options: -fno-warn-tabs
+    
+    -- not really part of GF but I have changed the original binary library
+    -- and we have to keep the copy for now.
+    Data.Binary
+    Data.Binary.Put
+    Data.Binary.Get
+    Data.Binary.Builder
+    Data.Binary.IEEE754
 
   if os(windows)
     build-depends:
@@ -352,44 +216,6 @@ library
       terminfo >=0.4.0 && < 0.5,
       unix >= 2.7.2 && < 2.8
 
-  if impl(ghc>=8.2)
-    ghc-options: -fhide-source-paths
-
-executable gf
-  hs-source-dirs: src/programs
-  main-is: gf-main.hs
-  default-language: Haskell2010
-  build-depends:
-    gf,
-    base
-  ghc-options: -threaded
---ghc-options: -fwarn-unused-imports
-
-  if impl(ghc>=7.0)
-    ghc-options: -rtsopts -with-rtsopts=-I5
-    if impl(ghc<7.8)
-      ghc-options: -with-rtsopts=-K64M
-
-  ghc-prof-options: -auto-all
-
-  if impl(ghc>=8.2)
-    ghc-options: -fhide-source-paths
-
--- executable pgf-shell
--- --if !flag(c-runtime)
---   buildable: False
---   main-is: pgf-shell.hs
---   hs-source-dirs: src/runtime/haskell-bind/examples
---   build-depends:
---     gf,
---     base,
---     containers,
---     mtl,
---     lifted-base
---   default-language: Haskell2010
---   if impl(ghc>=7.0)
---     ghc-options: -rtsopts
-
 test-suite gf-tests
   type: exitcode-stdio-1.0
   main-is: run.hs

src/compiler/GF/Command/Abstract.hs

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

src/compiler/GF/Command/CommandInfo.hs

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

src/compiler/GF/Command/Commands.hs

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

src/compiler/GF/Command/Commands2.hs

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

src/compiler/GF/Command/CommonCommands.hs

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

src/compiler/GF/Command/Importing.hs

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

src/compiler/GF/Command/Interpreter.hs

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

src/compiler/GF/Command/Parse.hs

@@ -1,6 +1,6 @@
 module GF.Command.Parse(readCommandLine, pCommand) where
 
-import PGF(pExpr,pIdent)
+import PGF2(pExpr,pIdent)
 import GF.Grammar.Parser(runPartial,pTerm)
 import GF.Command.Abstract
 
@@ -22,7 +22,7 @@ pCommandLine =
 pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
 
 pCommand = (do
-  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
+  cmd  <- readS_to_P pIdent <++ (char '%' >> fmap ('%':) (readS_to_P pIdent))
   skipSpaces
   opts <- sepBy pOption skipSpaces
   arg  <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
@@ -37,7 +37,7 @@ pCommand = (do
 
 pOption = do
   char '-'
-  flg <- pIdent
+  flg <- readS_to_P pIdent
   option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
 
 pValue = do
@@ -52,9 +52,9 @@ pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
 
 pArgument =
   option ANoArg
-    (fmap AExpr pExpr
+    (fmap AExpr (readS_to_P pExpr)
               <++
-    (skipSpaces >> char '%' >> fmap AMacro pIdent))
+    (skipSpaces >> char '%' >> fmap AMacro (readS_to_P pIdent)))
 
 pArgTerm = ATerm `fmap` readS_to_P sTerm
   where

src/compiler/GF/Command/TreeOperations.hs

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

src/compiler/GF/Compile.hs

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

src/compiler/GF/Compile/CFGtoPGF.hs

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

src/compiler/GF/Compile/CheckGrammar.hs

@@ -21,8 +21,8 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.CheckGrammar(checkModule) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
+import Prelude hiding ((<>))
 import GF.Infra.Ident
 import GF.Infra.Option
 

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

@@ -1,6 +1,6 @@
 module GF.Compile.Compute.Value where
 import GF.Grammar.Grammar(Label,Type,MetaId,Patt,QIdent)
-import PGF.Internal(BindType)
+import PGF2(BindType)
 import GF.Infra.Ident(Ident)
 import Text.Show.Functions()
 import Data.Ix(Ix)

src/compiler/GF/Compile/ExampleBased.hs

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

src/compiler/GF/Compile/Export.hs

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

src/compiler/GF/Compile/GenerateBC.hs

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

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -13,8 +13,9 @@ module GF.Compile.GeneratePMCFG
     (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
     ) where
 
---import PGF.CId
-import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)
+import qualified PGF2 as PGF2
+import qualified PGF2.Internal as PGF2
+import PGF2.Internal(Symbol(..),fidVar)
 
 import GF.Infra.Option
 import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -69,7 +70,7 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
 
 
 --addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
+addPMCFG opts gr cenv opath am cm seqs id (CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
 --when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
   let pres  = protoFCat gr res val
       pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
@@ -93,7 +94,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
     ePutStr ("\n+ "++showIdent id++" "++show (product (map catFactor pargs)))
   seqs1 `seq` stats `seq` return ()
   when (verbAtLeast opts Verbose) $ ePutStr (" "++show stats)
-  return (seqs1,GF.Grammar.CncFun mty mlin mprn (Just pmcfg))
+  return (seqs1,CncFun mty mlin mprn (Just pmcfg))
   where
     (ctxt,res,_) = err bug typeForm (lookupFunType gr am id)
 
@@ -103,11 +104,11 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
           newArgs  = map getFIds newArgs'
       in addFunction env0 newCat fun newArgs
 
-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
-                                                             mdef@(Just (L loc1 def))
-                                                             mref@(Just (L loc2 ref))
-                                                             mprn
-                                                             Nothing) = do
+addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat)) 
+                                                  mdef@(Just (L loc1 def))
+                                                  mref@(Just (L loc2 ref))
+                                                  mprn
+                                                  Nothing) = do
   let pcat = protoFCat gr (am,id) lincat
       pvar = protoFCat gr (MN identW,cVar) typeStr
 
@@ -132,7 +133,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ linc
   let pmcfg     = getPMCFG pmcfgEnv2
 
   when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" "++show (catFactor pcat))
-  seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
+  seqs2 `seq` pmcfg `seq` return (seqs2,CncCat mty mdef mref mprn (Just pmcfg))
   where
     addLindef lins (newCat', newArgs') env0 =
       let [newCat] = getFIds newCat'
@@ -158,12 +159,15 @@ convert opts gr cenv loc term ty@(_,val) pargs =
             args = map Vr vars
             vars = map (\(bt,x,t) -> x) context
 
-pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
-pgfCncCat gr lincat index =
+pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
+pgfCncCat gr id lincat index =
   let ((_,size),schema) = computeCatRange gr lincat
-  in PGF.CncCat index (index+size-1)
-                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
-                                    (getStrPaths schema)))
+  in ( id
+     , index
+     , index+size-1
+     , map (renderStyle style{mode=OneLineMode} . ppPath)
+           (getStrPaths schema)
+     )
   where
     getStrPaths :: Schema Identity s c -> [Path]
     getStrPaths = collect CNil []
@@ -475,7 +479,7 @@ goV (CPar t)     rpath ss = restrictHead (reversePath rpath) t >> return ss
 ----------------------------------------------------------------------
 -- SeqSet
 
-type SeqSet   = Map.Map Sequence SeqId
+type SeqSet   = Map.Map [Symbol] SeqId
 
 addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
 addSequencesB seqs (Case nr path bs) = let !(seqs1,bs1) = mapAccumL' (\seqs (trm,b) -> let !(seqs',b') = addSequencesB seqs b
@@ -504,13 +508,11 @@ mapAccumL' f s (x:xs) = (s'',y:ys)
                               !(s'',ys) = mapAccumL' f s' xs
 
 addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
-addSequence seqs lst =
+addSequence seqs seq =
   case Map.lookup seq seqs of
     Just id -> (seqs,id)
     Nothing -> let !last_seq = Map.size seqs
                in (Map.insert seq last_seq seqs, last_seq)
-  where
-    seq = mkArray lst
 
 
 ------------------------------------------------------------

src/compiler/GF/Compile/GetGrammar.hs

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

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -19,7 +19,7 @@ import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
 import GF.Infra.Option(Options,optionsPGF)
-import PGF.Internal(Literal(..))
+import PGF2.Internal(Literal(..))
 import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
 import System.FilePath ((</>), (<.>))
@@ -92,7 +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 :: 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 _ ->

src/compiler/GF/Compile/GrammarToPGF.hs

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

src/compiler/GF/Compile/OptimizePGF.hs

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

src/compiler/GF/Compile/PGFtoHaskell.hs

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

src/compiler/GF/Compile/PGFtoJS.hs

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

src/compiler/GF/Compile/PGFtoJSON.hs

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

src/compiler/GF/Compile/PGFtoJava.hs

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

src/compiler/GF/Compile/PGFtoProlog.hs

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

src/compiler/GF/Compile/PGFtoPython.hs

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

src/compiler/GF/Compile/ToAPI.hs

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

src/compiler/GF/CompileInParallel.hs

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

src/compiler/GF/Compiler.hs

@@ -1,8 +1,7 @@
-module GF.Compiler (mainGFC, linkGrammars, writePGF, writeOutputs) where
+module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
 
-import PGF
-import PGF.Internal(concretes,optimizePGF,unionPGF)
-import PGF.Internal(putSplitAbs,encodeFile,runPut)
+import PGF2
+import PGF2.Internal(unionPGF,writePGF,writeConcr)
 import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
@@ -92,7 +91,7 @@ compileSourceFiles opts fs =
 -- in the 'Options') from the output of 'parallelBatchCompile'.
 -- If a @.pgf@ file by the same name already exists and it is newer than the
 -- source grammar files (as indicated by the 'UTCTime' argument), it is not
--- recreated. Calls 'writePGF' and 'writeOutputs'.
+-- recreated. Calls 'writeGrammar' and 'writeOutputs'.
 linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
     do let abs = render (srcAbsName gr cnc)
            pgfFile = outputPath opts (grammarName' opts abs<.>"pgf")
@@ -102,10 +101,8 @@ linkGrammars opts (t_src,~cnc_grs@(~(cnc,gr):_)) =
        if t_pgf >= Just t_src
          then putIfVerb opts $ pgfFile ++ " is up-to-date."
          else do pgfs <- mapM (link opts) cnc_grs
-                 let pgf0 = foldl1 unionPGF pgfs
-                 probs <- maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf0
-                 let pgf = setProbabilities probs pgf0
-                 writePGF opts pgf
+                 let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
+                 writeGrammar opts pgf
                  writeOutputs opts pgf
 
 compileCFFiles :: Options -> [FilePath] -> IOE ()
@@ -115,12 +112,11 @@ compileCFFiles opts fs = do
   startCat <- case rules of
                 (Rule cat _ _ : _) -> return cat
                 _                  -> fail "empty CFG"
-  let pgf = cf2pgf (last fs) (mkCFG startCat Set.empty rules)
+  probs <- liftIO (maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts))
+  let pgf = cf2pgf opts (last fs) (mkCFG startCat Set.empty rules) probs
   unless (flag optStopAfterPhase opts == Compile) $
-     do probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
-        let pgf' = setProbabilities probs $ if flag optOptimizePGF opts then optimizePGF pgf else pgf
-        writePGF opts pgf'
-        writeOutputs opts pgf'
+     do writeGrammar opts pgf
+        writeOutputs opts pgf
 
 unionPGFFiles :: Options -> [FilePath] -> IOE ()
 unionPGFFiles opts fs =
@@ -138,14 +134,11 @@ unionPGFFiles opts fs =
 
     doIt =
       do pgfs <- mapM readPGFVerbose fs
-         let pgf0 = foldl1 unionPGF pgfs
-             pgf1 = if flag optOptimizePGF opts then optimizePGF pgf0 else pgf0
-         probs <- liftIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf1)
-         let pgf  = setProbabilities probs pgf1
-             pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
+         let pgf = foldl1 (\one two -> fromMaybe two (unionPGF one two)) pgfs
+         let pgfFile = outputPath opts (grammarName opts pgf <.> "pgf")
          if pgfFile `elem` fs
            then putStrLnE $ "Refusing to overwrite " ++ pgfFile
-           else writePGF opts pgf
+           else writeGrammar opts pgf
          writeOutputs opts pgf
 
     readPGFVerbose f =
@@ -162,21 +155,20 @@ 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 ()
-writePGF opts pgf =
-    if flag optSplitPGF opts then writeSplitPGF else writeNormalPGF
+writeGrammar :: Options -> PGF -> IOE ()
+writeGrammar 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
+          writing opts outfile (writePGF outfile pgf)
 
     writeSplitPGF =
       do let outfile = outputPath opts (grammarName opts pgf <.> "pgf")
-         writing opts outfile $ BSL.writeFile outfile (runPut (putSplitAbs pgf))
-                                --encodeFile_ outfile (putSplitAbs pgf)
-         forM_ (Map.toList (concretes pgf)) $ \cnc -> do
-           let outfile = outputPath opts (showCId (fst cnc) <.> "pgf_c")
-           writing opts outfile $ encodeFile outfile cnc
+         writing opts outfile $ writePGF outfile pgf
+         forM_ (Map.toList (languages pgf)) $ \(concrname,concr) -> do
+           let outfile = outputPath opts (concrname <.> "pgf_c")
+           writing opts outfile (writeConcr outfile concr)
 
 
 writeOutput :: Options -> FilePath-> String -> IOE ()
@@ -186,7 +178,7 @@ writeOutput opts file str = writing opts path $ writeUTF8File path str
 -- * Useful helper functions
 
 grammarName :: Options -> PGF -> String
-grammarName opts pgf = grammarName' opts (showCId (abstractName pgf))
+grammarName opts pgf = grammarName' opts (abstractName pgf)
 grammarName' opts abs = fromMaybe abs (flag optName opts)
 
 outputJustPGF opts = null (flag optOutputFormats opts) && not (flag optSplitPGF opts)

src/compiler/GF/Grammar/BNFC.hs

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

src/compiler/GF/Grammar/Binary.hs

@@ -10,9 +10,9 @@
 module GF.Grammar.Binary(VersionTagged(..),decodeModuleHeader,decodeModule,encodeModule) where
 
 import Prelude hiding (catch)
+import Control.Monad
 import Control.Exception(catch,ErrorCall(..),throwIO)
-
-import PGF.Internal(Binary(..),Word8,putWord8,getWord8,encodeFile,decodeFile)
+import Data.Binary
 import qualified Data.Map as Map(empty)
 import qualified Data.ByteString.Char8 as BS
 
@@ -22,8 +22,7 @@ import GF.Infra.Option
 import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
-import PGF() -- Binary instances
-import PGF.Internal(Literal(..))
+import PGF2.Internal(Literal(..),Symbol(..))
 
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF04"
@@ -298,6 +297,53 @@ instance Binary Label where
              1 -> fmap LVar   get
              _ -> decodingError
 
+instance Binary BindType where
+  put Explicit = putWord8 0
+  put Implicit = putWord8 1
+  get = do tag <- getWord8
+           case tag of
+             0 -> return Explicit
+             1 -> return Implicit
+             _ -> decodingError
+
+instance Binary Literal where
+  put (LStr s) = putWord8 0 >> put s
+  put (LInt i) = putWord8 1 >> put i
+  put (LFlt d) = putWord8 2 >> put d
+  get = do tag <- getWord8
+           case tag of
+             0 -> liftM  LStr get
+             1 -> liftM  LInt get
+             2 -> liftM  LFlt get
+             _ -> decodingError
+
+instance Binary Symbol where
+  put (SymCat n l)       = putWord8 0 >> put (n,l)
+  put (SymLit n l)       = putWord8 1 >> put (n,l)
+  put (SymVar n l)       = putWord8 2 >> put (n,l)
+  put (SymKS ts)         = putWord8 3 >> put ts
+  put (SymKP d vs)       = putWord8 4 >> put (d,vs)
+  put SymBIND            = putWord8 5
+  put SymSOFT_BIND       = putWord8 6
+  put SymNE              = putWord8 7
+  put SymSOFT_SPACE      = putWord8 8
+  put SymCAPIT           = putWord8 9
+  put SymALL_CAPIT       = putWord8 10
+  get = do tag <- getWord8
+           case tag of
+             0 -> liftM2 SymCat get get
+             1 -> liftM2 SymLit get get
+             2 -> liftM2 SymVar get get
+             3 -> liftM  SymKS  get
+             4 -> liftM2 (\d vs -> SymKP d vs) get get
+             5 -> return SymBIND
+             6 -> return SymSOFT_BIND
+             7 -> return SymNE
+             8 -> return SymSOFT_SPACE
+             9 -> return SymCAPIT
+             10-> return SymALL_CAPIT
+             _ -> decodingError
+
 --putGFOVersion = mapM_ (putWord8 . fromIntegral . ord) gfoVersion
 --getGFOVersion = replicateM (length gfoVersion) (fmap (chr . fromIntegral) getWord8)
 --putGFOVersion = put gfoVersion

src/compiler/GF/Grammar/CFG.hs

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

src/compiler/GF/Grammar/EBNF.hs

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

src/compiler/GF/Grammar/Grammar.hs

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
         Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
 
         -- ** PMCFG        
-        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence
+        PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
         ) where
 
 import GF.Infra.Ident
@@ -73,7 +73,8 @@ import GF.Infra.Location
 
 import GF.Data.Operations
 
-import PGF.Internal (FId, FunId, SeqId, LIndex, Sequence, BindType(..))
+import PGF2(BindType(..))
+import PGF2.Internal(FId, FunId, SeqId, LIndex, Symbol)
 
 import Data.Array.IArray(Array)
 import Data.Array.Unboxed(UArray)
@@ -99,7 +100,7 @@ data ModuleInfo = ModInfo {
     mopens  :: [OpenSpec],
     mexdeps :: [ModuleName],
     msrc    :: FilePath,
-    mseqs   :: Maybe (Array SeqId Sequence),
+    mseqs   :: Maybe (Array SeqId [Symbol]),
     jments  :: Map.Map Ident Info
   }
 

src/compiler/GF/Grammar/Parser.y

@@ -25,7 +25,6 @@ import GF.Compile.Update (buildAnyTree)
 import Data.List(intersperse)
 import Data.Char(isAlphaNum)
 import qualified Data.Map as Map
-import PGF(mkCId)
 
 }
 
@@ -625,7 +624,7 @@ ListCFRule
 
 CFRule :: { [BNFCRule] }
 CFRule
-  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (mkCId (showIdent $1)) [])]
+  : Ident '.' Ident '::=' ListCFSymbol ';' { [BNFCRule (showIdent $3) $5 (CFObj (showIdent $1) [])]
                                            }
   | Ident '::=' ListCFRHS ';'              { let { cat = showIdent $1;
                                                    mkFun cat its =
@@ -638,7 +637,7 @@ CFRule
                                                        Terminal    c     -> filter isAlphaNum c;
                                                        NonTerminal (t,_) -> t
                                                      }
-                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkCId (mkFun cat rhs)) [])) $3
+                                             } in map (\rhs -> BNFCRule cat rhs (CFObj (mkFun cat rhs) [])) $3
                                            }
   | 'coercions' Ident Integer ';'          { [BNFCCoercions (showIdent $2) $3]}
   | 'terminator' NonEmpty Ident String ';' { [BNFCTerminator $2 (showIdent $3) $4] }

src/compiler/GF/Grammar/Printer.hs

@@ -24,13 +24,13 @@ module GF.Grammar.Printer
            ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
+import PGF2 as PGF2
+import PGF2.Internal as PGF2
 import GF.Infra.Ident
 import GF.Infra.Option
 import GF.Grammar.Values
 import GF.Grammar.Grammar
 
-import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
-
 import GF.Text.Pretty
 import Data.Maybe (isNothing)
 import Data.List  (intersperse)
@@ -362,3 +362,40 @@ getLet :: Term -> ([LocalDef], Term)
 getLet (Let l e) = let (ls,e') = getLet e
                    in (l:ls,e')
 getLet e         = ([],e)
+
+ppFunId funid = pp 'F' <> pp funid
+ppSeqId seqid = pp 'S' <> pp seqid
+
+ppFId fid
+  | fid == PGF2.fidString = pp "CString"
+  | fid == PGF2.fidInt    = pp "CInt"
+  | fid == PGF2.fidFloat  = pp "CFloat"
+  | fid == PGF2.fidVar    = pp "CVar"
+  | fid == PGF2.fidStart  = pp "CStart"
+  | otherwise             = pp 'C' <> pp fid
+
+ppMeta :: Int -> Doc
+ppMeta n
+  | n == 0    = pp '?'
+  | otherwise = pp '?' <> pp n
+
+ppLit (PGF2.LStr s) = pp (show s)
+ppLit (PGF2.LInt n) = pp n
+ppLit (PGF2.LFlt d) = pp d
+
+ppSeq (seqid,seq) = 
+  ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq)
+
+ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>'
+ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
+ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
+ppSymbol (PGF2.SymKS t)    = doubleQuotes (pp t)
+ppSymbol PGF2.SymNE        = pp "nonExist"
+ppSymbol PGF2.SymBIND      = pp "BIND"
+ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
+ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE"
+ppSymbol PGF2.SymCAPIT     = pp "CAPIT"
+ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
+ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
+
+ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

src/compiler/GF/Infra/BuildInfo.hs

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

src/compiler/GF/Infra/CheckM.hs

@@ -18,8 +18,8 @@ module GF.Infra.CheckM
            checkIn, checkInModule, checkMap, checkMapRecover,
            parallelCheck, accumulateError, commitCheck,
           ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 import GF.Data.Operations
 --import GF.Infra.Ident
 --import GF.Grammar.Grammar(msrc) -- ,Context

src/compiler/GF/Infra/Ident.hs

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

src/compiler/GF/Infra/Location.hs

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

src/compiler/GF/Infra/Option.hs

@@ -34,16 +34,14 @@ import Data.Maybe
 import GF.Infra.Ident
 import GF.Infra.GetOpt
 import GF.Grammar.Predef
---import System.Console.GetOpt
 import System.FilePath
---import System.IO
+import PGF2.Internal(Literal(..))
 
 import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
 
 import Data.Set (Set)
 import qualified Data.Set as Set
 
-import PGF.Internal(Literal(..))
 import qualified Control.Monad.Fail as Fail
 
 usageHeader :: String
@@ -76,7 +74,6 @@ errors = raise . unlines
 
 data Mode = ModeVersion | ModeHelp
           | ModeInteractive | ModeRun
-          | ModeInteractive2 | ModeRun2
           | ModeCompiler
           | ModeServer {-port::-}Int
   deriving (Show,Eq,Ord)
@@ -95,7 +92,6 @@ data OutputFormat = FmtPGFPretty
                   | FmtPython
                   | FmtHaskell
                   | FmtJava
-                  | FmtProlog
                   | FmtBNF
                   | FmtEBNF
                   | FmtRegular
@@ -162,7 +158,7 @@ data Flags = Flags {
       optLiteralCats     :: Set Ident,
       optGFODir          :: Maybe FilePath,
       optOutputDir       :: Maybe FilePath,
-      optGFLibPath       :: Maybe [FilePath],
+      optGFLibPath       :: Maybe FilePath,
       optDocumentRoot    :: Maybe FilePath, -- For --server mode
       optRecomp          :: Recomp,
       optProbsFile       :: Maybe FilePath,
@@ -217,10 +213,9 @@ parseModuleOptions args = do
     then return opts
     else errors $ map ("Non-option among module options: " ++) nonopts
 
-fixRelativeLibPaths curr_dir lib_dirs (Options o) = Options (fixPathFlags . o)
+fixRelativeLibPaths curr_dir lib_dir (Options o) = Options (fixPathFlags . o)
   where
-    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [parent </> dir
-                                                                                      | parent <- curr_dir : lib_dirs]) path}
+    fixPathFlags f@(Flags{optLibraryPath=path}) = f{optLibraryPath=concatMap (\dir -> [curr_dir </> dir, lib_dir </> dir]) path}
 
 -- Showing options
 
@@ -316,8 +311,6 @@ optDescr =
      Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).",
      Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
      Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
-     Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.",
-     Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).",
      Option [] ["server"] (OptArg modeServer "port") $
        "Run in HTTP server mode on given port (default "++show defaultPort++").",
      Option [] ["document-root"] (ReqArg gfDocuRoot "DIR")
@@ -432,7 +425,7 @@ optDescr =
        literalCat  x = set $ \o -> o { optLiteralCats = foldr Set.insert (optLiteralCats o) ((map identS . splitBy (==',')) x) }
        lexicalCat  x = set $ \o -> o { optLexicalCats = foldr Set.insert (optLexicalCats o) (splitBy (==',') x) }
        outDir      x = set $ \o -> o { optOutputDir = Just x }
-       gfLibPath   x = set $ \o -> o { optGFLibPath = Just $ splitInModuleSearchPath x }
+       gfLibPath   x = set $ \o -> o { optGFLibPath = Just x }
        gfDocuRoot  x = set $ \o -> o { optDocumentRoot = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }
        probsFile   x = set $ \o -> o { optProbsFile = Just x }
@@ -480,12 +473,9 @@ outputFormatsExpl =
     [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
      (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
-     (("js",           FmtJavaScript),"JavaScript (whole grammar)"),
      (("json",         FmtJSON),"JSON (whole grammar)"),
-     (("python",       FmtPython),"Python (whole grammar)"),
      (("haskell",      FmtHaskell),"Haskell (abstract syntax)"),
      (("java",         FmtJava),"Java (abstract syntax)"),
-     (("prolog",       FmtProlog),"Prolog (whole grammar)"),
      (("bnf",          FmtBNF),"BNF (context-free grammar)"),
      (("ebnf",         FmtEBNF),"Extended BNF"),
      (("regular",      FmtRegular),"* regular grammar"),

src/compiler/GF/Infra/SIO.hs

@@ -12,9 +12,6 @@ module GF.Infra.SIO(
        newStdGen,print,putStr,putStrLn,
        -- ** Specific to GF
        importGrammar,importSource,
-#ifdef C_RUNTIME
-       readPGF2,
-#endif
        putStrLnFlush,runInterruptibly,lazySIO,
        -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
        -- | If the environment variable GF_RESTRICTED is defined, these
@@ -39,9 +36,6 @@ import qualified System.Random as IO(newStdGen)
 import qualified GF.Infra.UseIO as IO(getLibraryDirectory)
 import qualified GF.System.Signal as IO(runInterruptibly)
 import qualified GF.Command.Importing as GF(importGrammar, importSource)
-#ifdef C_RUNTIME
-import qualified PGF2
-#endif
 import qualified Control.Monad.Fail as Fail
 
 -- * The SIO monad
@@ -127,7 +121,3 @@ lazySIO              = lift1   lazyIO
 
 importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
 importSource      opts files = lift0 $ GF.importSource      opts files
-
-#ifdef C_RUNTIME
-readPGF2 = lift0 . PGF2.readPGF
-#endif

src/compiler/GF/Infra/UseIO.hs

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

src/compiler/GF/Interactive.hs

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

src/compiler/GF/Interactive2.hs

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

src/compiler/GF/Main.hs

@@ -2,10 +2,7 @@
 {-# LANGUAGE CPP #-}
 module GF.Main where
 import GF.Compiler
-import qualified GF.Interactive as GFI1
-#ifdef C_RUNTIME
-import qualified GF.Interactive2 as GFI2
-#endif
+import GF.Interactive
 import GF.Data.ErrM
 import GF.Infra.Option
 import GF.Infra.UseIO
@@ -48,17 +45,7 @@ mainOpts opts files =
     case flag optMode opts of
       ModeVersion     -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
       ModeHelp        -> putStrLn helpMessage
-      ModeServer port -> GFI1.mainServerGFI opts port files
+      ModeServer port -> mainServerGFI opts port files
       ModeCompiler    -> mainGFC opts files
-      ModeInteractive -> GFI1.mainGFI opts files
-      ModeRun         -> GFI1.mainRunGFI opts files
-#ifdef C_RUNTIME
-      ModeInteractive2 -> GFI2.mainGFI opts files
-      ModeRun2         -> GFI2.mainRunGFI opts files
-#else
-      ModeInteractive2 -> noCruntime
-      ModeRun2         -> noCruntime
-  where
-    noCruntime = do ePutStrLn "GF configured without C run-time support"
-                    exitFailure
-#endif
+      ModeInteractive -> mainGFI opts files
+      ModeRun         -> mainRunGFI opts files

src/compiler/GF/Quiz.hs

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

src/compiler/GF/Server.hs

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

src/compiler/GF/Speech/CFGToFA.hs

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

src/compiler/GF/Speech/GSL.hs

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

src/compiler/GF/Speech/JSGF.hs

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

src/compiler/GF/Speech/PGFToCFG.hs

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

src/compiler/GF/Speech/PrRegExp.hs

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

src/compiler/GF/Speech/SISR.hs

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

src/compiler/GF/Speech/SLF.hs

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

src/compiler/GF/Speech/SRG.hs

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

src/compiler/GF/Speech/SRGS_ABNF.hs

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

src/compiler/GF/Speech/SRGS_XML.hs

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

src/compiler/GF/Speech/VoiceXML.hs

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

src/compiler/GF/System/NoSignal.hs

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

src/compiler/GF/Text/Lexing.hs

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

src/compiler/GF/Text/Transliterations.hs

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

src/compiler/SimpleEditor/Convert.hs

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

src/example-based/ExampleDemo.hs

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

src/example-based/ExampleService.hs

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

src/example-based/exb-fcgi.hs

@@ -1,15 +0,0 @@
-{-# LANGUAGE CPP #-}
-import Control.Concurrent(forkIO)
-import Network.FastCGI(runFastCGI,runFastCGIConcurrent')
-import ExampleService(cgiMain,newPGFCache)
-
-main = do --stderrToFile logFile
-          fcgiMain =<< newPGFCache
-
-
-fcgiMain cache =
-#ifndef mingw32_HOST_OS
-          runFastCGIConcurrent' forkIO 100 (cgiMain cache)
-#else
-          runFastCGI (cgiMain cache)
-#endif

src/example-based/gf-exb.cabal

@@ -1,25 +0,0 @@
-Name: gf-exb
-Version: 1.0
-Cabal-version: >= 1.8
-Build-type: Simple
-License: GPL
-Synopsis: Example-based grammar writing for the Grammatical Framework
-
-executable exb.fcgi
-  main-is: exb-fcgi.hs
-  Hs-source-dirs: . ../server ../compiler ../runtime/haskell
-  other-modules: ExampleService ExampleDemo
-                 CGIUtils Cache GF.Compile.ToAPI
-                 -- and a lot more...
-  ghc-options: -threaded
-  if impl(ghc>=7.0)
-    ghc-options: -rtsopts
-
-  build-depends: base >=4.2 && <5, json, cgi, fastcgi, random,
-                 containers, old-time, directory, bytestring, utf8-string,
-                 pretty, array, mtl, time, filepath
-
-  if os(windows)
-    ghc-options: -optl-mwindows
-  else
-    build-depends: unix

src/example-based/todo.txt

@@ -1,20 +0,0 @@
-
-Editor improvements for example-based grammar writing:
-+ Remove the same language from the example language menu
-+ Send the other language environment to getNext
-- Compile a new .pgf automatically when needed
-- Update buttons automatically when functions are added or removed
-- Switch over to using AbsParadigmsEng.pgf instead of the old exprToAPI function
-
-Editor support for guided construction of linearization functions
-- enter api expressions by parsing them with AbsParadigmsEng.pgf in minibar
-- replace simpleParseInput with one that accepts quoted string literals
-- use lexcode/unlexcode in minibar
-- better support for literals in minibar (completion info from the PGF
-  library should indicate if literals are acceptable)
-
-Server support for example-based grammar writing:
-- Change getNext to use info from the example language
-- Random generator restricted to defined functions
-
-- More testing

src/runtime/c/Makefile.am

@@ -84,8 +84,8 @@ libpgf_la_SOURCES = \
 	pgf/graphviz.c \
 	pgf/aligner.c \
 	pgf/pgf.c \
-	pgf/pgf.h
-libpgf_la_LDFLAGS = -no-undefined
+	pgf/pgf.h \
+libpgf_la_LDFLAGS = "-no-undefined"
 libpgf_la_LIBADD = libgu.la
 
 bin_PROGRAMS =

src/runtime/c/gu/defs.h

@@ -23,14 +23,6 @@
 
 #define restrict __restrict
 
-#elif defined(__MINGW32__)
-
-#define GU_API_DECL
-#define GU_API
-
-#define GU_INTERNAL_DECL
-#define GU_INTERNAL
-
 #else
 
 #define GU_API_DECL
@@ -38,9 +30,7 @@
 
 #define GU_INTERNAL_DECL  __attribute__ ((visibility ("hidden")))
 #define GU_INTERNAL       __attribute__ ((visibility ("hidden")))
-
 #endif
-
 // end MSVC workaround
 
 #include <stddef.h>

src/runtime/c/libsg.pc.in

@@ -1,10 +0,0 @@
-prefix=@prefix@
-exec_prefix=@exec_prefix@
-libdir=@libdir@
-includedir=@includedir@
-
-Name: libsg
-Description: Semantic Graph library
-Version: @VERSION@
-Libs: -L${libdir} -lsg -lpgf 
-Cflags: -I${includedir}

src/runtime/c/pgf/expr.c

@@ -30,8 +30,8 @@ pgf_expr_unwrap(PgfExpr expr)
 	}
 }
 
-PGF_API int
-pgf_expr_arity(PgfExpr expr)
+static PgfExprTag
+pgf_expr_arity(PgfExpr expr, int *arity)
 {
 	int n = 0;
 	while (true) {
@@ -44,10 +44,9 @@ pgf_expr_arity(PgfExpr expr)
 			n = n + 1;
 			break;
 		}
-		case PGF_EXPR_FUN:
-			return n;
 		default:
-			return -1;
+			*arity = n;
+			return i.tag;
 		}
 	}
 }
@@ -55,8 +54,8 @@ pgf_expr_arity(PgfExpr expr)
 PGF_API PgfApplication*
 pgf_expr_unapply(PgfExpr expr, GuPool* pool)
 {
-	int arity = pgf_expr_arity(expr);
-	if (arity < 0) {
+	int arity;
+	if (pgf_expr_arity(expr, &arity) != PGF_EXPR_FUN) {
 		return NULL;
 	}
 	PgfApplication* appl = gu_new_flex(pool, PgfApplication, args, arity);
@@ -68,13 +67,38 @@ pgf_expr_unapply(PgfExpr expr, GuPool* pool)
 		appl->args[n] = app->arg;
 		expr = app->fun;
 	}
-	PgfExpr e = pgf_expr_unwrap(expr);
-	gu_assert(gu_variant_tag(e) == PGF_EXPR_FUN);
-	PgfExprFun* fun = gu_variant_data(e);
+	appl->efun = pgf_expr_unwrap(expr);
+	gu_assert(gu_variant_tag(appl->efun) == PGF_EXPR_FUN);
+	PgfExprFun* fun = gu_variant_data(appl->efun);
 	appl->fun = fun->fun;
 	return appl;
 }
 
+PGF_API PgfApplication*
+pgf_expr_unapply_ex(PgfExpr expr, GuPool* pool)
+{
+	int arity;
+	pgf_expr_arity(expr, &arity);
+
+	PgfApplication* appl = gu_new_flex(pool, PgfApplication, args, arity);
+	appl->n_args = arity;
+	for (int n = arity - 1; n >= 0; n--) {
+		PgfExpr e = pgf_expr_unwrap(expr);
+		gu_assert(gu_variant_tag(e) == PGF_EXPR_APP);
+		PgfExprApp* app = gu_variant_data(e);
+		appl->args[n] = app->arg;
+		expr = app->fun;
+	}
+	appl->efun = pgf_expr_unwrap(expr);
+	if (gu_variant_tag(appl->efun) == PGF_EXPR_FUN) {
+		PgfExprFun* fun = gu_variant_data(appl->efun);
+		appl->fun = fun->fun;
+	} else {
+		appl->fun = NULL;
+	}
+	return appl;
+}
+
 PGF_API PgfExpr
 pgf_expr_apply(PgfApplication* app, GuPool* pool)
 {
@@ -675,6 +699,17 @@ pgf_expr_parser_binds(PgfExprParser* parser)
 	return binds;
 }
 
+PGF_API GuString
+pgf_expr_parser_ident(PgfExprParser* parser)
+{
+	GuString ident = NULL;
+	if (parser->token_tag == PGF_TOKEN_IDENT) {
+		ident =	gu_string_copy(gu_string_buf_data(parser->token_value), parser->expr_pool);
+		pgf_expr_parser_token(parser, true);
+	}
+	return ident;
+}
+
 PGF_API PgfExpr
 pgf_expr_parser_expr(PgfExprParser* parser, bool mark)
 {

src/runtime/c/pgf/expr.h

@@ -126,12 +126,10 @@ typedef struct {
 	PgfExpr expr;
 } PgfExprProb;
 
-PGF_API_DECL int
-pgf_expr_arity(PgfExpr expr);
-
 typedef struct PgfApplication PgfApplication;
 
 struct PgfApplication {
+	PgfExpr efun;
 	PgfCId fun;
 	int n_args;
 	PgfExpr args[];
@@ -140,6 +138,9 @@ struct PgfApplication {
 PGF_API_DECL PgfApplication*
 pgf_expr_unapply(PgfExpr expr, GuPool* pool);
 
+PGF_API_DECL PgfApplication*
+pgf_expr_unapply_ex(PgfExpr expr, GuPool* pool);
+
 PGF_API_DECL PgfExpr
 pgf_expr_apply(PgfApplication*, GuPool* pool);
 

src/runtime/c/pgf/linearizer.c

@@ -175,9 +175,8 @@ redo:;
 		gu_buf_get(buf, PgfProductionApply*, index);
 	gu_assert(n_args == gu_seq_length(papply->args));
 
-	capp->abs_id = papply->fun->absfun->name;
-	capp->fun    = papply->fun;
-	capp->fid    = 0;
+	capp->fun = papply->fun;
+	capp->fid = 0;
 	capp->n_args = n_args;
 
 	for (size_t i = 0; i < n_args; i++) {
@@ -223,10 +222,10 @@ redo:;
 static PgfCncTree
 pgf_cnc_resolve_def(PgfCnc* cnc,
                     size_t n_vars, PgfPrintContext* context,
-                    PgfCId abs_id, PgfCCat* ccat, GuString s, GuPool* pool)
+                    PgfCCat* ccat, GuString s, GuPool* pool)
 {
-	PgfCncTree ret = gu_null_variant;
 	PgfCncTree lit = gu_null_variant;
+	PgfCncTree ret = gu_null_variant;
 
 	PgfCncTreeLit* clit =
 		gu_new_variant(PGF_CNC_TREE_LIT,
@@ -234,7 +233,7 @@ pgf_cnc_resolve_def(PgfCnc* cnc,
 					   &lit, pool);
 	clit->n_vars  = 0;
 	clit->context = context;
-	clit->fid     = -1;  // don't report the literal in the bracket
+	clit->fid = cnc->fid++;
 	PgfLiteralStr* lit_str =
 		gu_new_flex_variant(PGF_LITERAL_STR,
 					        PgfLiteralStr,
@@ -242,7 +241,7 @@ pgf_cnc_resolve_def(PgfCnc* cnc,
 					        &clit->lit, pool);
 	strcpy((char*) lit_str->val, (char*) s);
 
-	if (ccat == NULL || ccat->lindefs == NULL)
+	if (ccat->lindefs == NULL)
 		return lit;
 
 	int index =
@@ -254,10 +253,9 @@ pgf_cnc_resolve_def(PgfCnc* cnc,
 		gu_new_flex_variant(PGF_CNC_TREE_APP,
 							PgfCncTreeApp,
 							args, 1, &ret, pool);
-	capp->ccat  = ccat;
-	capp->abs_id= abs_id;
-	capp->fun   = gu_seq_get(ccat->lindefs, PgfCncFun*, index);
-	capp->fid   = cnc->fid++;
+	capp->ccat = ccat;
+	capp->fun = gu_seq_get(ccat->lindefs, PgfCncFun*, index);
+	capp->fid = cnc->fid++;
 	capp->n_vars  = n_vars;
 	capp->context = context;
 	capp->n_args  = 1;
@@ -297,7 +295,7 @@ pgf_lzr_wrap_linref(PgfCncTree ctree, GuPool* pool)
 		PgfCncTreeApp* capp = cti.data;
 
 		assert(gu_seq_length(capp->ccat->linrefs) > 0);
-
+	
 		// here we must apply the linref function
 		PgfCncTree new_ctree;
 		PgfCncTreeApp* new_capp =
@@ -305,7 +303,6 @@ pgf_lzr_wrap_linref(PgfCncTree ctree, GuPool* pool)
 						PgfCncTreeApp,
 						args, 1, &new_ctree, pool);
 		new_capp->ccat    = NULL;
-		new_capp->abs_id  = NULL;
 		new_capp->fun     = gu_seq_get(capp->ccat->linrefs, PgfCncFun*, 0);
 		new_capp->fid     = -1;
 		new_capp->n_vars  = 0;
@@ -317,7 +314,7 @@ pgf_lzr_wrap_linref(PgfCncTree ctree, GuPool* pool)
 		break;
 	}
 	}
-
+	
 	return ctree;
 }
 
@@ -399,17 +396,6 @@ pgf_cnc_resolve(PgfCnc* cnc,
 				goto done;
 			}
 
-			PgfCId abs_id = "?";
-			if (emeta->id > 0) {
-				GuPool* tmp_pool = gu_local_pool();
-				GuExn* err = gu_new_exn(tmp_pool);
-				GuStringBuf* sbuf = gu_new_string_buf(tmp_pool);
-				GuOut* out = gu_string_buf_out(sbuf);
-
-				gu_printf(out, err, "?%d", emeta->id);
-				abs_id = gu_string_buf_freeze(sbuf, pool);
-			}
-
 			int index =
 				gu_choice_next(cnc->ch, gu_seq_length(ccat->lindefs));
 			if (index < 0) {
@@ -420,7 +406,6 @@ pgf_cnc_resolve(PgfCnc* cnc,
 									PgfCncTreeApp,
 									args, 1, &ret, pool);
 			capp->ccat = ccat;
-			capp->abs_id = abs_id;
 			capp->fun = gu_seq_get(ccat->lindefs, PgfCncFun*, index);
 			capp->fid = cnc->fid++;
 			capp->n_vars = 0;
@@ -450,7 +435,23 @@ pgf_cnc_resolve(PgfCnc* cnc,
 				gu_putc(']', out, err);
 				GuString s = gu_string_buf_freeze(sbuf, tmp_pool);
 
-				ret = pgf_cnc_resolve_def(cnc, n_vars, context, efun->fun, ccat, s, pool);
+				if (ccat != NULL) {
+					ret = pgf_cnc_resolve_def(cnc, n_vars, context, ccat, s, pool);
+				} else {
+					PgfCncTreeLit* clit = 
+						gu_new_variant(PGF_CNC_TREE_LIT,
+									   PgfCncTreeLit,
+									   &ret, pool);
+					clit->n_vars = 0;
+					clit->context = context;
+					clit->fid = cnc->fid++;
+					PgfLiteralStr* lit = 
+						gu_new_flex_variant(PGF_LITERAL_STR,
+									        PgfLiteralStr,
+									        val, strlen(s)+1,
+									        &clit->lit, pool);
+					strcpy(lit->val, s);
+				}
 
 				gu_pool_free(tmp_pool);
 				goto done;
@@ -498,7 +499,28 @@ redo:;
 				index--;
 			}
 
-			ret = pgf_cnc_resolve_def(cnc, n_vars, context, ctxt->name, ccat, ctxt->name, pool);
+			if (ccat != NULL && ccat->lindefs == NULL) {
+				goto done;
+			}
+
+			if (ccat != NULL) {
+				ret = pgf_cnc_resolve_def(cnc, n_vars, context, ccat, ctxt->name, pool);
+			} else {
+				PgfCncTreeLit* clit = 
+					gu_new_variant(PGF_CNC_TREE_LIT,
+								   PgfCncTreeLit,
+								   &ret, pool);
+				clit->n_vars  = 0;
+				clit->context = context;
+				clit->fid = cnc->fid++;
+				PgfLiteralStr* lit = 
+					gu_new_flex_variant(PGF_LITERAL_STR,
+								        PgfLiteralStr,
+								        val, strlen(ctxt->name)+1,
+								        &clit->lit, pool);
+				strcpy(lit->val, ctxt->name);
+			}
+
 			goto done;
 		}
 		case PGF_EXPR_TYPED: {
@@ -919,7 +941,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 			(*lzr->funcs)->begin_phrase(lzr->funcs,
 			                            fapp->ccat->cnccat->abscat->name,
 			                            fapp->fid, fapp->ccat->cnccat->labels[lin_idx],
-			                            fapp->abs_id);
+			                            fun->absfun->name);
 		}
 
 		gu_require(lin_idx < fun->n_lins);
@@ -929,7 +951,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 			(*lzr->funcs)->end_phrase(lzr->funcs,
 			                          fapp->ccat->cnccat->abscat->name,
 			                          fapp->fid, fapp->ccat->cnccat->labels[lin_idx],
-			                          fapp->abs_id);
+			                          fun->absfun->name);
 		}
 		break;
 	}
@@ -955,7 +977,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 		PgfCId cat =
 			pgf_literal_cat(lzr->concr, flit->lit)->cnccat->abscat->name;
 		
-		if ((*lzr->funcs)->begin_phrase && flit->fid >= 0) {
+		if ((*lzr->funcs)->begin_phrase) {
 			(*lzr->funcs)->begin_phrase(lzr->funcs,
 			                            cat, flit->fid, "s",
 			                            "");
@@ -987,7 +1009,7 @@ pgf_lzr_linearize_tree(PgfLzr* lzr, PgfCncTree ctree, size_t lin_idx)
 			(*lzr->funcs)->symbol_token(lzr->funcs, tok);
 		}
 
-		if ((*lzr->funcs)->end_phrase && flit->fid >= 0) {
+		if ((*lzr->funcs)->end_phrase) {
 			(*lzr->funcs)->end_phrase(lzr->funcs,
 							          cat, flit->fid, "s",
 							          "");

src/runtime/c/pgf/linearizer.h

@@ -22,7 +22,6 @@ typedef enum {
 
 typedef struct {
 	PgfCCat* ccat;
-	PgfCId abs_id;
 	PgfCncFun* fun;
 	int fid;
 

src/runtime/c/pgf/lookup.c

@@ -9,9 +9,6 @@
 #include <stdio.h>
 #include <stdlib.h>
 #include <math.h>
-#if defined(__MINGW32__) || defined(_MSC_VER)
-#include <malloc.h>
-#endif
 
 //#define PGF_LOOKUP_DEBUG
 //#define PGF_LINEARIZER_DEBUG
@@ -119,7 +116,7 @@ typedef struct {
 static PgfAbsProduction*
 pgf_lookup_new_production(PgfAbsFun* fun, GuPool *pool)
 {
-	size_t n_hypos = fun->type->hypos ? gu_seq_length(fun->type->hypos) : 0;
+	size_t n_hypos = gu_seq_length(fun->type->hypos);
 	PgfAbsProduction* prod = gu_new_flex(pool, PgfAbsProduction, args, n_hypos);
 	prod->fun = fun;
 	prod->count = 0;
@@ -699,12 +696,8 @@ pgf_lookup_tokenize(GuMap* lexicon_idx, GuString sentence, GuPool* pool)
 			break;
 
 		const uint8_t* start = p-1;
-		if (strchr(".!?,:",c) != NULL)
+		while (c != 0 && !gu_ucs_is_space(c)) {
 			c = gu_utf8_decode(&p);
-		else {
-			while (c != 0 && strchr(".!?,:",c) == NULL && !gu_ucs_is_space(c)) {
-				c = gu_utf8_decode(&p);
-			}
 		}
 		const uint8_t* end   = p-1;
 

src/runtime/c/pgf/parser.c

@@ -1682,6 +1682,8 @@ pgf_parsing_init(PgfConcr* concr, PgfCId cat,
 	start_ccat->prods = NULL;
 	start_ccat->n_synprods = 0;
 
+	gu_assert(start_ccat->cnccat != NULL);
+
 #ifdef PGF_COUNTS_DEBUG
 	ps->ccat_full_count++;
 #endif
@@ -2336,7 +2338,7 @@ pgf_parser_completions_next(GuEnum* self, void* to, GuPool* pool)
 }
 
 PGF_API GuEnum*
-pgf_complete(PgfConcr* concr, PgfType* type, GuString sentence, 
+pgf_complete(PgfConcr* concr, PgfType* type, GuString sentence,
              GuString prefix, GuExn *err, GuPool* pool)
 {
 	if (concr->sequences == NULL ||

src/runtime/c/pgf/pgf.c

@@ -46,7 +46,7 @@ pgf_read_in(GuIn* in,
 }
 
 PGF_API_DECL void
-pgf_write(PgfPGF* pgf, const char* fpath, GuExn* err)
+pgf_write(PgfPGF* pgf, size_t n_concrs, PgfConcr** concrs, const char* fpath, GuExn* err)
 {
 	FILE* outfile = fopen(fpath, "wb");
 	if (outfile == NULL) {
@@ -60,13 +60,70 @@ pgf_write(PgfPGF* pgf, const char* fpath, GuExn* err)
 	GuOut* out = gu_file_out(outfile, tmp_pool);
 
 	PgfWriter* wtr = pgf_new_writer(out, tmp_pool, err);
-	pgf_write_pgf(pgf, wtr);
+	pgf_write_pgf(pgf, n_concrs, concrs, wtr);
 
 	gu_pool_free(tmp_pool);
 	
 	fclose(outfile);
 }
 
+PGF_API void
+pgf_concrete_save(PgfConcr* concr, const char* fpath, GuExn* err)
+{
+	FILE* outfile = fopen(fpath, "wb");
+	if (outfile == NULL) {
+		gu_raise_errno(err);
+		return;
+	}
+
+	GuPool* tmp_pool = gu_local_pool();
+
+	// Create an input stream from the input file
+	GuOut* out = gu_file_out(outfile, tmp_pool);
+
+	PgfWriter* wtr = pgf_new_writer(out, tmp_pool, err);
+	pgf_write_concrete(concr, wtr, true);
+
+	gu_pool_free(tmp_pool);
+	
+	fclose(outfile);
+}
+
+PGF_API bool
+pgf_have_same_abstract(PgfPGF *one, PgfPGF *two)
+{
+	if (strcmp(one->abstract.name, two->abstract.name) != 0)
+		return false;
+
+	size_t n_cats = gu_seq_length(one->abstract.cats);
+	if (n_cats != gu_seq_length(two->abstract.cats))
+		return false;
+	size_t n_funs = gu_seq_length(one->abstract.funs);
+	if (n_funs != gu_seq_length(two->abstract.funs))
+		return false;
+
+	for (size_t i = 0; i < n_cats; i++) {
+		PgfAbsCat* cat1 = gu_seq_index(one->abstract.cats, PgfAbsCat, i);
+		PgfAbsCat* cat2 = gu_seq_index(two->abstract.cats, PgfAbsCat, i);
+		
+		if (strcmp(cat1->name, cat2->name) != 0)
+			return false;
+	}
+
+	for (size_t i = 0; i < n_funs; i++) {
+		PgfAbsFun* fun1 = gu_seq_index(one->abstract.funs, PgfAbsFun, i);
+		PgfAbsFun* fun2 = gu_seq_index(two->abstract.funs, PgfAbsFun, i);
+		
+		if (strcmp(fun1->name, fun2->name) != 0)
+			return false;
+
+		if (!pgf_type_eq(fun1->type, fun2->type))
+			return false;
+	}
+
+	return true;
+}
+
 PGF_API GuString
 pgf_abstract_name(PgfPGF* pgf)
 {
@@ -184,7 +241,7 @@ pgf_language_code(PgfConcr* concr)
 		gu_seq_binsearch(concr->cflags, pgf_flag_order, PgfFlag, "language");
 
 	if (flag == NULL)
-		return "";
+		return NULL;
 
 	GuVariantInfo i = gu_variant_open(flag->value);
 	switch (i.tag) {
@@ -194,7 +251,7 @@ pgf_language_code(PgfConcr* concr)
 	}
 	}
 
-	return "";
+	return NULL;
 }
 
 PGF_API void

src/runtime/c/pgf/pgf.h

@@ -19,14 +19,6 @@
 #define PGF_INTERNAL_DECL
 #define PGF_INTERNAL
 
-#elif defined(__MINGW32__)
-
-#define PGF_API_DECL
-#define PGF_API
-
-#define PGF_INTERNAL_DECL
-#define PGF_INTERNAL
-
 #else
 
 #define PGF_API_DECL
@@ -66,7 +58,10 @@ PGF_API_DECL void
 pgf_concrete_unload(PgfConcr* concr);
 
 PGF_API_DECL void
-pgf_write(PgfPGF* pgf, const char* fpath, GuExn* err);
+pgf_write(PgfPGF* pgf, size_t n_concrs, PgfConcr** concrs, const char* fpath, GuExn* err);
+
+PGF_API_DECL bool
+pgf_have_same_abstract(PgfPGF *one, PgfPGF *two);
 
 PGF_API_DECL GuString
 pgf_abstract_name(PgfPGF*);
@@ -274,7 +269,8 @@ pgf_callbacks_map_add_literal(PgfConcr* concr, PgfCallbacksMap* callbacks,
                               PgfCId cat, PgfLiteralCallback* callback);
 
 PGF_API_DECL void
-pgf_print(PgfPGF* pgf, GuOut* out, GuExn* err); 
+pgf_print(PgfPGF* pgf, size_t n_concrs, PgfConcr** concrs,
+          GuOut* out, GuExn* err);
 
 PGF_API_DECL void
 pgf_check_expr(PgfPGF* gr, PgfExpr* pe, PgfType* ty,

src/runtime/c/pgf/printer.c

@@ -7,13 +7,17 @@ typedef struct {
 } PgfPrintFn;
 
 static void
-pgf_print_flags(PgfFlags* flags, GuOut *out, GuExn* err)
+pgf_print_flags(PgfFlags* flags, int indent, GuOut *out, GuExn* err)
 {
 	size_t n_flags = gu_seq_length(flags);
 	for (size_t i = 0; i < n_flags; i++) {
 		PgfFlag* flag = gu_seq_index(flags, PgfFlag, i);
-		
-		gu_puts("  flag ", out, err);
+
+		for (int k = 0; k < indent; k++) {
+			gu_putc(' ', out, err);
+		}
+
+		gu_puts("flag ", out, err);
 		pgf_print_cid(flag->name, out, err);
 		gu_puts(" = ", out, err);
 		pgf_print_literal(flag->value, out, err);
@@ -70,7 +74,7 @@ pgf_print_abstract(PgfAbstr* abstr, GuOut* out, GuExn* err)
 	pgf_print_cid(abstr->name, out, err);
 	gu_puts(" {\n", out, err);
 
-	pgf_print_flags(abstr->aflags, out, err);
+	pgf_print_flags(abstr->aflags, 2, out, err);
 	pgf_print_abscats(abstr->cats, out, err);
 	pgf_print_absfuns(abstr->funs, out, err);
 
@@ -385,7 +389,7 @@ pgf_print_concrete(PgfConcr* concr, GuOut* out, GuExn* err)
 	pgf_print_cid(concr->name, out, err);
 	gu_puts(" {\n", out, err);
 
-	pgf_print_flags(concr->cflags, out, err);
+	pgf_print_flags(concr->cflags, 2, out, err);
 
 	gu_puts("  productions\n", out, err);
 	PgfPrintFn clo2 = { { pgf_print_productions }, out };
@@ -423,13 +427,12 @@ pgf_print_concrete(PgfConcr* concr, GuOut* out, GuExn* err)
 }
 
 PGF_API void
-pgf_print(PgfPGF* pgf, GuOut* out, GuExn* err)
+pgf_print(PgfPGF* pgf, size_t n_concrs, PgfConcr** concrs, GuOut* out, GuExn* err)
 {
+	pgf_print_flags(pgf->gflags, 0, out, err);
 	pgf_print_abstract(&pgf->abstract, out, err);
-	
-	size_t n_concrs = gu_seq_length(pgf->concretes);
+
 	for (size_t i = 0; i < n_concrs; i++) {
-		PgfConcr* concr = gu_seq_index(pgf->concretes, PgfConcr, i);
-		pgf_print_concrete(concr, out, err);
+		pgf_print_concrete(concrs[i], out, err);
 	}
 }

src/runtime/c/pgf/reader.c

@@ -942,7 +942,7 @@ pgf_read_pargs(PgfReader* rdr, PgfConcr* concr)
 }
 
 PGF_API bool
-pgf_production_is_lexical(PgfProductionApply *papp, 
+pgf_production_is_lexical(PgfProductionApply *papp,
                           GuBuf* non_lexical_buf, GuPool* pool)
 {
 	if (gu_seq_length(papp->args) > 0)
@@ -1174,6 +1174,14 @@ pgf_read_ccat_cb(GuMapItor* fn, const void* key, void* value, GuExn* err)
 //	pgf_ccat_set_viterbi_prob(ccat);
 }
 
+// The GF compiler needs to call this function when building in memory grammars.
+PGF_API void
+pgf_concrete_fix_internals(PgfConcr* concr)
+{
+	GuMapItor clo1 = { pgf_read_ccat_cb };
+	gu_map_iter(concr->ccats, &clo1, NULL);
+}
+
 static void
 pgf_read_concrete_content(PgfReader* rdr, PgfConcr* concr)
 {
@@ -1199,8 +1207,7 @@ pgf_read_concrete_content(PgfReader* rdr, PgfConcr* concr)
 	concr->cnccats = pgf_read_cnccats(rdr, concr->abstr, concr);
 	concr->total_cats = pgf_read_int(rdr);
 
-	GuMapItor clo1 = { pgf_read_ccat_cb };
-	gu_map_iter(concr->ccats, &clo1, NULL);
+	pgf_concrete_fix_internals(concr);
 }
 
 static void

src/runtime/c/pgf/writer.c

@@ -72,10 +72,15 @@ pgf_write_cid(PgfCId id, PgfWriter* wtr)
 PGF_INTERNAL void
 pgf_write_string(GuString val, PgfWriter* wtr)
 {	
-	size_t len = strlen(val);
+	size_t len = 0;
+	const uint8_t* buf = (const uint8_t*) val;
+	const uint8_t* p   = buf;
+	while (gu_utf8_decode(&p) != 0)
+		len++;
+
 	pgf_write_len(len, wtr);
 	gu_return_on_exn(wtr->err, );
-	gu_out_bytes(wtr->out, (uint8_t*) val, len, wtr->err);
+	gu_out_bytes(wtr->out, (uint8_t*) val, (p-buf)-1, wtr->err);
 }
 
 PGF_INTERNAL void
@@ -843,7 +848,7 @@ pgf_write_concrete_content(PgfConcr* concr, PgfWriter* wtr)
 	pgf_write_int(concr->total_cats, wtr);
 }
 
-static void
+PGF_INTERNAL void
 pgf_write_concrete(PgfConcr* concr, PgfWriter* wtr, bool with_content)
 {
 	if (with_content &&
@@ -865,34 +870,20 @@ pgf_write_concrete(PgfConcr* concr, PgfWriter* wtr, bool with_content)
 	gu_return_on_exn(wtr->err, );
 }
 
-PGF_API void
-pgf_concrete_save(PgfConcr* concr, GuOut* out, GuExn* err)
-{
-	GuPool* pool = gu_new_pool();
-
-	PgfWriter* wtr = pgf_new_writer(out, pool, err);
-
-	pgf_write_concrete(concr, wtr, true);
-
-	gu_pool_free(pool);
-}
-
 static void
-pgf_write_concretes(PgfConcrs* concretes, PgfWriter* wtr, bool with_content)
+pgf_write_concretes(size_t n_concrs, PgfConcr** concrs, PgfWriter* wtr, bool with_content)
 {
-	size_t n_concrs = gu_seq_length(concretes);
 	pgf_write_len(n_concrs, wtr);
 	gu_return_on_exn(wtr->err, );
 
 	for (size_t i = 0; i < n_concrs; i++) {
-		PgfConcr* concr = gu_seq_index(concretes, PgfConcr, i);
-		pgf_write_concrete(concr, wtr, with_content);
+		pgf_write_concrete(concrs[i], wtr, with_content);
 		gu_return_on_exn(wtr->err, );
 	}
 }
 
 PGF_INTERNAL void
-pgf_write_pgf(PgfPGF* pgf, PgfWriter* wtr) {
+pgf_write_pgf(PgfPGF* pgf, size_t n_concrs, PgfConcr** concrs, PgfWriter* wtr) {
 	gu_out_u16be(wtr->out, pgf->major_version, wtr->err);
 	gu_return_on_exn(wtr->err, );
 
@@ -907,7 +898,7 @@ pgf_write_pgf(PgfPGF* pgf, PgfWriter* wtr) {
 
 	bool with_content =
 		(gu_seq_binsearch(pgf->gflags, pgf_flag_order, PgfFlag, "split") == NULL);
-	pgf_write_concretes(pgf->concretes, wtr, with_content);
+	pgf_write_concretes(n_concrs, concrs, wtr, with_content);
 	gu_return_on_exn(wtr->err, );
 }
 

src/runtime/c/pgf/writer.h

@@ -33,7 +33,10 @@ pgf_write_len(size_t len, PgfWriter* wtr);
 PGF_INTERNAL_DECL void
 pgf_write_cid(PgfCId id, PgfWriter* wtr);
 
+PGF_INTERNAL void
+pgf_write_concrete(PgfConcr* concr, PgfWriter* wtr, bool with_content);
+
 PGF_INTERNAL_DECL void
-pgf_write_pgf(PgfPGF* pgf, PgfWriter* wtr);
+pgf_write_pgf(PgfPGF* pgf, size_t n_concrs, PgfConcr** concrs, PgfWriter* wtr);
 
 #endif // WRITER_H_

src/runtime/haskell-bind/pgf2.cabal

@@ -1,49 +0,0 @@
-name: pgf2
-version: 1.3.0
-
-cabal-version: 1.22
-build-type: Simple
-license: LGPL-3
-license-file: LICENSE
-category: Natural Language Processing
-synopsis: Bindings to the C version of the PGF runtime
-description:
-  GF, Grammatical Framework, is a programming language for multilingual grammar applications.
-  GF grammars are compiled into Portable Grammar Format (PGF) which can be used with the PGF runtime, written in C.
-  This package provides Haskell bindings to that runtime.
-homepage: https://www.grammaticalframework.org/
-bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-author: Krasimir Angelov
-extra-source-files: CHANGELOG.md, README.md
-tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
-
-library
-  exposed-modules:
-    PGF2,
-    PGF2.Internal
-  other-modules:
-    PGF2.FFI,
-    PGF2.Expr,
-    PGF2.Type
-  build-depends:
-    base >= 4.9.1 && < 4.15,
-    containers >= 0.5.7 && < 0.7,
-    pretty >= 1.1.3 && < 1.2
-  default-language: Haskell2010
-  build-tools: hsc2hs
-  extra-libraries: pgf gu
-  cc-options: -std=c99
-  c-sources: utils.c
-
--- executable pgf-shell
---   main-is: pgf-shell.hs
---   hs-source-dirs: examples
---   build-depends:
---     base,
---     containers,
---     lifted-base,
---     mtl,
---     pgf2
---   default-language: Haskell2010
---   if impl(ghc>=7.0)
---     ghc-options: -rtsopts

src/runtime/haskell-bind/stack-ghc7.10.3.yaml

@@ -1,3 +0,0 @@
-resolver: lts-6.35 # ghc 7.10.3
-
-allow-newer: true

src/runtime/haskell-bind/stack-ghc8.0.2.yaml

@@ -1 +0,0 @@
-resolver: lts-9.21 # ghc 8.0.2

src/runtime/haskell-bind/stack-ghc8.10.4.yaml

@@ -1 +0,0 @@
-resolver: lts-18.0 # ghc 8.10.4

src/runtime/haskell/PGF.hs

@@ -1,397 +1,228 @@
-{-# LANGUAGE BangPatterns #-}
--------------------------------------------------
--- |
--- Module      : PGF
--- Maintainer  : Krasimir Angelov
--- Stability   : stable
--- Portability : portable
---
--- This module is an Application Programming Interface to 
--- load and interpret grammars compiled in Portable Grammar Format (PGF).
--- The PGF format is produced as a final output from the GF compiler.
--- The API is meant to be used for embedding GF grammars in Haskell 
--- programs
--------------------------------------------------
+module PGF (PGF2.PGF, readPGF, showPGF,
+            abstractName,
 
-module PGF(
-           -- * PGF
-           PGF,
-           readPGF,
-           parsePGF,
+            CId, mkCId, wildCId, showCId, readCId,
+            
+            categories, categoryContext, categoryProbability,
+            functions, functionsByCat, functionType, functionIsDataCon, browse,
 
-           -- * Identifiers
-           CId, mkCId, wildCId,
-           showCId, readCId,
-           -- extra
-           ppCId, pIdent, utf8CId,
+            PGF2.Expr,Tree,showExpr,PGF2.readExpr,pExpr,pIdent,
+            mkAbs,unAbs,
+            mkApp,unApp,unapply,
+            PGF2.mkStr,PGF2.unStr,
+            PGF2.mkInt,PGF2.unInt,
+            PGF2.mkFloat,PGF2.unFloat,
+            PGF2.mkMeta,PGF2.unMeta,
+            PGF2.exprSize, exprFunctions,PGF2.exprSubstitute,
+            compute,
+            rankTreesByProbs,treeProbability,
 
-           -- * Languages
-           Language, 
-           showLanguage, readLanguage,
-           languages, abstractName, languageCode,
+            TcError, ppTcError, inferExpr, checkType,
 
-           -- * Types
-           Type, Hypo,
-           showType, readType,
-           mkType, mkHypo, mkDepHypo, mkImplHypo,
-           unType,
-           categories, categoryContext, startCat,
+            PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType,
+            mkType, unType,
 
-           -- * Functions
-           functions, functionsByCat, functionType, missingLins,
+            PGF2.Token, PGF2.FId,
 
-           -- * Expressions & Trees
-           -- ** Tree
-           Tree,
+            Language, readLanguage, showLanguage,
+            languages, startCat, languageCode,
+            linearize, bracketedLinearize, tabularLinearizes, showBracketedString,
+            ParseOutput(..), parse, parse_, complete,
+            PGF2.BracketedString(..), PGF2.flattenBracketedString,
+            hasLinearization,
+            showPrintName,
+            
+            Morpho, buildMorpho,
+            lookupMorpho, isInMorpho, morphoMissing, morphoKnown, fullFormLexicon,
 
-           -- ** Expr
-           Expr,
-           showExpr, readExpr,
-           mkAbs,    unAbs,
-           mkApp,    unApp, unapply,
-           mkStr,    unStr,
-           mkInt,    unInt,
-           mkDouble, unDouble,
-           mkFloat,  unFloat,
-           mkMeta,   unMeta,
-           -- extra
-           pExpr, exprSize, exprFunctions,
+            Labels, getDepLabels, CncLabels, getCncDepLabels,
 
-           -- * Operations
-           -- ** Linearization
-           linearize, linearizeAllLang, linearizeAll, bracketedLinearize, bracketedLinearizeAll, tabularLinearizes,
-           groupResults, -- lins of trees by language, removing duplicates
-           showPrintName,
-           
-           BracketedString(..), FId, LIndex, Token,
-           Forest.showBracketedString,flattenBracketedString,
+            generateAllDepth, generateRandom, generateRandomFrom, generateRandomDepth, generateRandomFromDepth,
+            generateFromDepth,
 
-           -- ** Parsing
-           parse, parseAllLang, parseAll, parse_, parseWithRecovery, complete,
+            PGF2.GraphvizOptions(..),
+            graphvizAbstractTree, graphvizParseTree, graphvizAlignment, graphvizDependencyTree, graphvizParseTreeDep,
 
-           -- ** Evaluation
-           PGF.compute, paraphrase,
+            -- * Tries
+            ATree(..),Trie(..),toATree,toTrie,
+            
+            readProbabilitiesFromFile,
+            
+            groupResults, conlls2latexDoc, gizaAlignment
+           ) where
 
-           -- ** Type Checking
-           -- | The type checker in PGF does both type checking and renaming
-           -- i.e. it verifies that all identifiers are declared and it
-           -- distinguishes between global function or type indentifiers and
-           -- variable names. The type checker should always be applied on
-           -- expressions entered by the user i.e. those produced via functions
-           -- like 'readType' and 'readExpr' because otherwise unexpected results
-           -- could appear. All typechecking functions returns updated versions
-           -- of the input types or expressions because the typechecking could
-           -- also lead to metavariables instantiations.
-           checkType, checkExpr, inferExpr,
-           TcError(..), ppTcError,
-
-           -- ** Low level parsing API
-           Parse.ParseState,
-           Parse.initState, Parse.nextState, Parse.getCompletions, Parse.recoveryStates, 
-           Parse.ParseInput(..),  Parse.simpleParseInput, Parse.mkParseInput,
-           Parse.ParseOutput(..), Parse.getParseOutput,
-           Parse.getContinuationInfo,
-
-           -- ** Generation
-           -- | The PGF interpreter allows automatic generation of
-           -- abstract syntax expressions of a given type. Since the
-           -- type system of GF allows dependent types, the generation
-           -- is in general undecidable. In fact, the set of all type
-           -- signatures in the grammar is equivalent to a Turing-complete language (Prolog).
-           --
-           -- There are several generation methods which mainly differ in:
-           --
-           --     * whether the expressions are sequentially or randomly generated?
-           --
-           --     * are they generated from a template? The template is an expression
-           --     containing meta variables which the generator will fill in.
-           --
-           --     * is there a limit of the depth of the expression?
-           --     The depth can be used to limit the search space, which 
-           --     in some cases is the only way to make the search decidable.
-           generateAll,         generateAllDepth,
-           generateFrom,        generateFromDepth,
-           generateRandom,      generateRandomDepth,
-           generateRandomFrom,  generateRandomFromDepth,
-
-           -- ** Morphological Analysis
-           Lemma, Analysis, Morpho,
-           lookupMorpho, buildMorpho, fullFormLexicon,
-           morphoMissing,
-           -- extra:
-           morphoKnown, isInMorpho,
-
-           -- ** Visualizations
-           graphvizAbstractTree,
-           graphvizParseTree,
-           graphvizParseTreeDep,
-           graphvizDependencyTree,
-           graphvizBracketedString,
-           graphvizAlignment,
-           gizaAlignment,
-           GraphvizOptions(..),
-           graphvizDefaults,
-           conlls2latexDoc,
-           -- extra:
-           Labels, getDepLabels,
-           CncLabels, getCncDepLabels,
- 
-           -- * Probabilities
-           Probabilities,
-           mkProbabilities,
-           defaultProbabilities,
-           showProbabilities,
-           readProbabilitiesFromFile,
-           -- extra:
-           probTree, setProbabilities, rankTreesByProbs,
-           
-           -- -- ** SortTop
---         forExample,
-
-           -- * Browsing
-           browse,
-           -- * Tries
-           ATree(..),Trie(..),toATree,toTrie
-          ) where
-
-import PGF.CId
-import PGF.Linearize
---import PGF.SortTop
-import PGF.Generate
-import PGF.TypeCheck
-import PGF.Paraphrase
-import PGF.VisualizeTree
-import PGF.Probabilistic
-import PGF.Macros
-import PGF.Expr (Tree)
-import PGF.Morphology
-import PGF.Data
-import PGF.Binary ()
-import qualified PGF.Forest as Forest
-import qualified PGF.Parse as Parse
-import PGF.Utilities(replace)
-
---import Data.Char
+import qualified PGF2 as PGF2
+import qualified PGF2.Internal as PGF2
 import qualified Data.Map as Map
---import qualified Data.IntMap as IntMap
---import Data.Maybe
-import Data.Binary
-import Data.ByteString.Lazy (ByteString)
-import Data.List(mapAccumL)
---import System.Random (newStdGen)
---import Control.Monad
-import Text.PrettyPrint
+import qualified Text.ParserCombinators.ReadP as RP
+import Data.List(sortBy)
+import Text.PrettyPrint(text)
+import Data.Char(isDigit)
 
----------------------------------------------------
--- Interface
----------------------------------------------------
+newtype CId = CId String deriving (Show,Read,Eq,Ord)
 
--- | Reads file in Portable Grammar Format and produces
--- 'PGF' structure. The file is usually produced with:
---
--- > $ gf -make <grammar file name>
-readPGF  :: FilePath -> IO PGF
+type Language = CId
 
--- | Like @readPGF@ but you have the manage file-handling.
---
--- @since 3.9.1
-parsePGF :: ByteString -> PGF
+lookConcr gr (CId lang) =
+  case Map.lookup lang (PGF2.languages gr) of
+    Just cnc -> cnc
+    Nothing  -> error "Unknown language"
 
--- | Tries to parse the given string in the specified language
--- and to produce abstract syntax expression.
-parse        :: PGF -> Language -> Type -> String -> [Tree]
+readPGF = PGF2.readPGF
 
--- | The same as 'parseAllLang' but does not return
--- the language.
-parseAll     :: PGF -> Type -> String -> [[Tree]]
+showPGF gr = PGF2.showPGF gr
 
--- | Tries to parse the given string with all available languages.
--- The returned list contains pairs of language
--- and list of abstract syntax expressions 
--- (this is a list, since grammars can be ambiguous). 
--- Only those languages
--- for which at least one parsing is possible are listed.
-parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
+readLanguage = readCId
+showLanguage (CId s) = s
 
--- | The same as 'parse' but returns more detailed information
-parse_       :: PGF -> Language -> Type -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
+startCat = PGF2.startCat
+languageCode pgf lang = Just (PGF2.languageCode (lookConcr pgf lang))
 
--- | This is an experimental function. Use it on your own risk
-parseWithRecovery :: PGF -> Language -> Type -> [Type] -> Maybe Int -> String -> (Parse.ParseOutput,BracketedString)
+abstractName gr = CId (PGF2.abstractName gr)
 
--- | List of all languages available in the given grammar.
-languages    :: PGF -> [Language]
+categories gr = map CId (PGF2.categories gr)
+categoryContext gr (CId c) = PGF2.categoryContext gr c
+categoryProbability gr (CId c) = PGF2.categoryProbability gr c
 
--- | Gets the RFC 4646 language tag 
--- of the language which the given concrete syntax implements,
--- if this is listed in the source grammar.
--- Example language tags include @\"en\"@ for English,
--- and @\"en-UK\"@ for British English.
-languageCode :: PGF -> Language -> Maybe String
+functions gr  = map CId (PGF2.functions gr)
+functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c)
+functionType gr (CId f) = PGF2.functionType gr f
+functionIsDataCon gr (CId f) = PGF2.functionIsDataCon gr f
 
--- | The abstract language name is the name of the top-level
--- abstract module
-abstractName :: PGF -> Language
-
--- | List of all categories defined in the given grammar.
--- The categories are defined in the abstract syntax
--- with the \'cat\' keyword.
-categories :: PGF -> [CId]
-
-categoryContext :: PGF -> CId -> Maybe [Hypo]
-
--- | The start category is defined in the grammar with
--- the \'startcat\' flag. This is usually the sentence category
--- but it is not necessary. Despite that there is a start category
--- defined you can parse with any category. The start category
--- definition is just for convenience.
-startCat   :: PGF -> Type
-
--- | List of all functions defined in the abstract syntax
-functions :: PGF -> [CId]
-
--- | List of all functions defined for a given category
-functionsByCat :: PGF -> CId -> [CId]
-
--- | The type of a given function
-functionType :: PGF -> CId -> Maybe Type
+type Tree = PGF2.Expr
+type Labels = Map.Map CId [String]
+type CncLabels = [(String, String -> Maybe (String -> String,String,String))]
 
 
----------------------------------------------------
--- Implementation
----------------------------------------------------
+mkCId x = CId x
+wildCId = CId "_"
+showCId (CId x) = x
+readCId s = Just (CId s)
 
-readPGF = decodeFile
+showExpr xs e = PGF2.showExpr [x | CId x <- xs] e
 
-parsePGF = decode
+pExpr = RP.readS_to_P PGF2.pExpr
+pIdent = RP.readS_to_P PGF2.pIdent
 
-parse pgf lang typ s =
-  case parse_ pgf lang typ (Just 4) s of
-    (Parse.ParseOk ts,_) -> ts
-    _                    -> []
+mkAbs bind_type (CId var) e = PGF2.mkAbs bind_type var e
+unAbs e = case PGF2.unAbs e of
+            Just (bind_type, var, e) -> Just (bind_type, CId var, e)
+            Nothing                  -> Nothing
 
-parseAll mgr typ = map snd . parseAllLang mgr typ
+mkApp (CId f) es = PGF2.mkApp f es
+unApp e = case PGF2.unApp e of
+            Just (f,es) -> Just (CId f,es)
+            Nothing     -> Nothing
 
-parseAllLang mgr typ s = 
-  [(lang,ts) | lang <- languages mgr, (Parse.ParseOk ts,_) <- [parse_ mgr lang typ (Just 4) s]]
+unapply = PGF2.unapply
 
-parse_ pgf lang typ dp s = 
-  case Map.lookup lang (concretes pgf) of
-    Just cnc -> Parse.parse pgf lang typ dp (words s)
-    Nothing  -> error ("Unknown language: " ++ showCId lang)
+instance Read PGF2.Expr where
+    readsPrec _ s = case PGF2.readExpr s of
+                      Just e  -> [(e,"")]
+                      Nothing -> []
 
-parseWithRecovery pgf lang typ open_typs dp s = Parse.parseWithRecovery pgf lang typ open_typs dp (words s)
+showType xs ty = PGF2.showType [x | CId x <- xs] ty
+showContext xs hypos = PGF2.showContext [x | CId x <- xs] hypos
 
-complete :: PGF -> Language -> Type -> String -> String -> (BracketedString,String,Map.Map Token [CId])
-complete pgf from typ input prefix =
-  let ws  = words input
-      ps0 = Parse.initState pgf from typ
-      (ps,ws') = loop ps0 ws
-      bs       = snd (Parse.getParseOutput ps typ Nothing)
-  in if not (null ws')
-       then (bs, unwords (if null prefix then ws' else ws'++[prefix]), Map.empty)
-       else (bs, prefix, fmap getFuns (Parse.getCompletions ps prefix))
-  where
-    loop ps []     = (ps,[])
-    loop ps (w:ws) = case Parse.nextState ps (Parse.simpleParseInput w) of
-                       Left  es -> (ps,w:ws)
-                       Right ps -> loop ps ws
+mkType hypos (CId var) es = PGF2.mkType [(bt,var,ty) | (bt,CId var,ty) <- hypos] var es
+unType ty = case PGF2.unType ty of
+              (hypos,var,es) -> ([(bt,CId var,ty) | (bt,var,ty) <- hypos],CId var,es)
 
-    getFuns ps = [cid | (funid,cid,seq) <- snd . head $ Map.toList contInfo]
-      where
-        contInfo = Parse.getContinuationInfo ps
+linearize pgf lang e = PGF2.linearize (lookConcr pgf lang) e
+bracketedLinearize pgf lang e = PGF2.bracketedLinearize (lookConcr pgf lang) e
+tabularLinearizes pgf lang e = [PGF2.tabularLinearize (lookConcr pgf lang) e]
+showBracketedString = PGF2.showBracketedString
 
-groupResults :: [[(Language,String)]] -> [(Language,[String])]
-groupResults = Map.toList . foldr more Map.empty . start . concat
- where
-  start ls = [(l,[s]) | (l,s) <- ls]
-  more (l,s) = 
-    Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s
+type TcError = String
 
-abstractName pgf = absname pgf
+-- | This data type encodes the different outcomes which you could get from the parser.
+data ParseOutput
+  = ParseFailed Int                -- ^ The integer is the position in number of tokens where the parser failed.
+  | TypeError   [(PGF2.FId,TcError)]    -- ^ The parsing was successful but none of the trees is type correct. 
+                                   -- The forest id ('FId') points to the bracketed string from the parser
+                                   -- where the type checking failed. More than one error is returned
+                                   -- if there are many analizes for some phrase but they all are not type correct.
+  | ParseOk [Tree]                 -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees.
+                                   -- The list should be non-empty.
+  | ParseIncomplete                -- ^ The sentence is not complete. Only partial output is produced
 
-languages pgf = Map.keys (concretes pgf)
+parse pgf lang cat s = 
+  case PGF2.parse (lookConcr pgf lang) cat s of
+    PGF2.ParseOk ts -> map fst ts
+    _               -> []
 
-languageCode pgf lang = 
-    case lookConcrFlag pgf lang (mkCId "language") of
-      Just (LStr s) -> Just (replace '_' '-' s)
-      _             -> Nothing
+parse_ pgf lang cat dp s =
+  case PGF2.parse (lookConcr pgf lang) cat s of
+    PGF2.ParseFailed pos _ -> (ParseFailed pos,      PGF2.Leaf s)
+    PGF2.ParseOk ts        -> (ParseOk (map fst ts), PGF2.Leaf s)
+    PGF2.ParseIncomplete   -> (ParseIncomplete,      PGF2.Leaf s)
 
-categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
+complete pgf lang cat s prefix = 
+  let compls = Map.fromListWith (++) [(tok,[CId fun]) | PGF2.ParseOk res <- [PGF2.complete (lookConcr pgf lang) cat s prefix], (tok,_,fun,_) <- res]
+  in (PGF2.Leaf [],s,compls)
 
-categoryContext pgf cat =
-  case Map.lookup cat (cats (abstract pgf)) of
-    Just (hypos,_,_) -> Just hypos
-    Nothing          -> Nothing
+hasLinearization pgf lang (CId f) = PGF2.hasLinearization (lookConcr pgf lang) f
 
-startCat pgf = DTyp [] (lookStartCat pgf) []
+ppTcError s = s
 
-functions pgf = Map.keys (funs (abstract pgf))
+inferExpr gr e = 
+  case PGF2.inferExpr gr e of
+    Right res -> Right res
+    Left  msg -> Left (text msg)
 
-functionsByCat pgf cat =
-  case Map.lookup cat (cats (abstract pgf)) of
-    Just (_,fns,_) -> map snd fns
-    Nothing        -> []
+checkType gr ty = 
+  case PGF2.checkType gr ty of
+    Right res -> Right res
+    Left  msg -> Left (text msg)
 
-functionType pgf fun =
-  case Map.lookup fun (funs (abstract pgf)) of
-    Just (ty,_,_,_) -> Just ty
-    Nothing         -> Nothing
+showPrintName pgf lang (CId f) = 
+  case PGF2.printName (lookConcr pgf lang) f of
+    Just n  -> n
+    Nothing -> f
 
--- | Converts an expression to normal form
-compute :: PGF -> Expr -> Expr
-compute pgf = PGF.Data.normalForm (funs (abstract pgf),const Nothing) 0 []
+getDepLabels :: String -> Labels
+getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
 
-exprSize :: Expr -> Int
-exprSize (EAbs _ _ e) = exprSize e
-exprSize (EApp e1 e2) = exprSize e1 + exprSize e2
-exprSize (ETyped e ty)= exprSize e
-exprSize (EImplArg e) = exprSize e
-exprSize _            = 1
+getCncDepLabels :: String -> CncLabels
+getCncDepLabels = PGF2.getCncDepLabels
 
-exprFunctions :: Expr -> [CId]
-exprFunctions (EAbs _ _ e) = exprFunctions e
-exprFunctions (EApp e1 e2) = exprFunctions e1 ++ exprFunctions e2
-exprFunctions (ETyped e ty)= exprFunctions e
-exprFunctions (EImplArg e) = exprFunctions e
-exprFunctions (EFun f)     = [f]
-exprFunctions _            = []
+generateAllDepth gr ty _ = map fst (PGF2.generateAll gr ty)
+generateFromDepth = error "generateFromDepth is not implemented"
+generateRandom = error "generateRandom is not implemented"
+generateRandomFrom = error "generateRandomFrom is not implemented"
+generateRandomDepth = error "generateRandomDepth is not implemented"
+generateRandomFromDepth = error "generateRandomFromDepth is not implemented"
 
---exprFunctions :: Expr -> [Fun]
+exprFunctions e = [CId f | f <- PGF2.exprFunctions e]
 
-browse :: PGF -> CId -> Maybe (String,[CId],[CId])
-browse pgf id = fmap (\def -> (def,producers,consumers)) definition
-  where
-    definition = case Map.lookup id (funs (abstract pgf)) of
-                   Just (ty,_,Just (eqs,_),_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
-                                                                if null eqs
-                                                                  then empty
-                                                                  else text "def" <+> vcat [let scope = foldl pattScope [] patts
-                                                                                                ds    = map (ppPatt 9 scope) patts
-                                                                                            in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
-                   Just (ty,_,Nothing,_)      -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
-                   Nothing   -> case Map.lookup id (cats (abstract pgf)) of
-                                  Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
-                                  Nothing         -> Nothing
+compute = error "compute is not implemented"
 
-    (producers,consumers) = Map.foldrWithKey accum ([],[]) (funs (abstract pgf))
-      where
-        accum f (ty,_,_,_) (plist,clist) = 
-          let !plist' = if id `elem` ps then f : plist else plist
-              !clist' = if id `elem` cs then f : clist else clist
-          in (plist',clist')
-          where
-            (ps,cs) = tyIds ty
+-- | rank from highest to lowest probability
+rankTreesByProbs :: PGF2.PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)]
+rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p) 
+  [(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts]
 
-    tyIds (DTyp hyps cat es) = (foldr expIds (cat:concat css) es,concat pss)
-      where
-        (pss,css) = unzip [tyIds ty | (_,_,ty) <- hyps]
+treeProbability = PGF2.treeProbability
 
-    expIds (EAbs _ _ e) ids = expIds e ids
-    expIds (EApp e1 e2) ids = expIds e1 (expIds e2 ids)
-    expIds (EFun id)    ids = id : ids
-    expIds (ETyped e _) ids = expIds e ids
-    expIds _            ids = ids
+languages pgf = fmap CId (Map.keys (PGF2.languages pgf))
+
+type Morpho = PGF2.Concr
+
+buildMorpho pgf lang = lookConcr pgf lang
+lookupMorpho cnc w = [(CId lemma,an) | (lemma,an,_) <- PGF2.lookupMorpho cnc w]
+isInMorpho cnc w = not (null (PGF2.lookupMorpho cnc w))
+fullFormLexicon cnc = [(w, [(CId fun,an) | (fun,an,_) <- analyses]) | (w, analyses) <- PGF2.fullFormLexicon cnc]
+
+graphvizAbstractTree pgf (funs,cats) = PGF2.graphvizAbstractTree pgf PGF2.graphvizDefaults{PGF2.noFun=not funs,PGF2.noCat=not cats}
+graphvizParseTree pgf lang  = PGF2.graphvizParseTree (lookConcr pgf lang)
+graphvizAlignment pgf langs  = PGF2.graphvizWordAlignment (map (lookConcr pgf) langs) PGF2.graphvizDefaults
+graphvizDependencyTree format debug lbls cnclbls pgf lang e = 
+  let to_lbls' lbls = Map.fromList [(id,xs) | (CId id,xs) <- Map.toList lbls]
+  in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e
+graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented"
+
+browse :: PGF2.PGF -> CId -> Maybe (String,[CId],[CId])
+browse = error "browse is not implemented"
 
 -- | A type for plain applicative trees
 data ATree t = Other t    | App CId  [ATree t]  deriving Show
@@ -400,9 +231,9 @@ data Trie    = Oth   Tree | Ap  CId [[Trie   ]] deriving Show
 
 -- | Convert a 'Tree' to an 'ATree'
 toATree :: Tree -> ATree Tree
-toATree e = maybe (Other e) app (unApp e)
+toATree e = maybe (Other e) app (PGF2.unApp e)
   where
-    app (f,es) = App f (map toATree es)
+    app (f,es) = App (mkCId f) (map toATree es)
 
 -- | Combine a list of trees into a trie
 toTrie = combines . map ((:[]) . singleton)
@@ -423,3 +254,30 @@ toTrie = combines . map ((:[]) . singleton)
           where
             combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us)))
             combine2 _ = Nothing
+
+readProbabilitiesFromFile :: FilePath -> IO (Map.Map CId Double)
+readProbabilitiesFromFile fpath = do
+  s <- readFile fpath
+  return $ Map.fromList [(mkCId f,read p) | f:p:_ <- map words (lines s)]
+
+groupResults :: [[(Language,String)]] -> [(Language,[String])]
+groupResults = Map.toList . foldr more Map.empty . start . concat
+ where
+  start ls = [(l,[s]) | (l,s) <- ls]
+  more (l,s) = 
+    Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s
+
+conlls2latexDoc = error "conlls2latexDoc is not implemented"
+
+
+morphoMissing  :: Morpho -> [String] -> [String]
+morphoMissing = morphoClassify False
+
+morphoKnown    :: Morpho -> [String] -> [String]
+morphoKnown = morphoClassify True
+
+morphoClassify :: Bool -> Morpho -> [String] -> [String]
+morphoClassify k mo ws = [w | w <- ws, k /= null (lookupMorpho mo w), notLiteral w] where
+  notLiteral w = not (all isDigit w) ---- should be defined somewhere
+
+gizaAlignment = error "gizaAlignment is not implemented"

src/runtime/haskell/PGF/Binary.hs

@@ -1,282 +0,0 @@
-module PGF.Binary(putSplitAbs) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Optimize
-import PGF.ByteCode
-import qualified PGF.OldBinary as Old
-import Data.Binary
-import Data.Binary.Put
-import Data.Binary.Get
-import Data.Array.IArray
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
---import qualified Data.Set as Set
-import Control.Monad
-
-pgfMajorVersion, pgfMinorVersion :: Word16
-version@(pgfMajorVersion, pgfMinorVersion) = (2,1)
-
-instance Binary PGF where
-  put pgf = do putWord16be pgfMajorVersion
-               putWord16be pgfMinorVersion
-               put (gflags pgf)
-               put (absname pgf, abstract pgf)
-               put (concretes pgf)
-  get = do major<- getWord16be
-           minor <- getWord16be
-           let v = (major,minor)
-           if major==pgfMajorVersion && minor<=pgfMinorVersion
-             then getPGF'
-             else if v==Old.version
-                  then Old.getPGF'
-                  else fail $ "Unsupported PGF version "++show (major,minor)
-
-getPGF'=do gflags <- get
-           (absname,abstract) <- get
-           concretes <- get
-           return $ updateProductionIndices $
-                      (PGF{ gflags=gflags
-                          , absname=absname, abstract=abstract
-                          , concretes=concretes
-                          })
-
-instance Binary CId where
-  put (CId bs) = put bs
-  get    = liftM CId get
-
-instance Binary Abstr where
-  put abs = do put (aflags abs)
-               put (Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap fst mb_eq,prob)) (funs abs))
-               put (cats abs)
-  get = do aflags <- get
-           funs <- get
-           cats <- get
-           return (Abstr{ aflags=aflags
-                        , funs=Map.map (\(ty,arity,mb_eq,prob) -> (ty,arity,fmap (\eq -> (eq,[])) mb_eq,prob)) funs
-                        , cats=cats
-                        })
-
-putSplitAbs :: PGF -> Put
-putSplitAbs pgf = do
-  putWord16be pgfMajorVersion
-  putWord16be pgfMinorVersion
-  put (Map.insert (mkCId "split") (LStr "true") (gflags pgf))
-  put (absname pgf, abstract pgf)
-  put [(name,cflags cnc) | (name,cnc) <- Map.toList (concretes pgf)]
-
-instance Binary Concr where
-  put cnc = do put (cflags cnc)
-               put (printnames cnc)
-               putArray2 (sequences cnc)
-               putArray (cncfuns cnc)
-               put (lindefs cnc)
-               put (linrefs cnc)
-               put (productions cnc)
-               put (cnccats cnc)
-               put (totalCats cnc)
-  get = do cflags      <- get
-           printnames  <- get
-           sequences   <- getArray2
-           cncfuns     <- getArray
-           lindefs     <- get
-           linrefs     <- get
-           productions <- get
-           cnccats     <- get
-           totalCats   <- get
-           return (Concr{ cflags=cflags, printnames=printnames
-                        , sequences=sequences, cncfuns=cncfuns
-                        , lindefs=lindefs, linrefs=linrefs
-                        , productions=productions
-                        , pproductions = IntMap.empty
-                        , lproductions = Map.empty
-                        , lexicon = IntMap.empty
-                        , cnccats=cnccats, totalCats=totalCats
-                        })
-
-instance Binary Expr where
-  put (EAbs b x exp)  = putWord8 0 >> put (b,x,exp)
-  put (EApp e1 e2)    = putWord8 1 >> put (e1,e2)
-  put (ELit l)        = putWord8 2 >> put l
-  put (EMeta i)       = putWord8 3 >> put i
-  put (EFun  f)       = putWord8 4 >> put f
-  put (EVar  i)       = putWord8 5 >> put i
-  put (ETyped e ty)   = putWord8 6 >> put (e,ty)
-  put (EImplArg e)    = putWord8 7 >> put e
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM3 EAbs get get get
-             1 -> liftM2 EApp get get
-             2 -> liftM  ELit get
-             3 -> liftM  EMeta get
-             4 -> liftM  EFun get
-             5 -> liftM  EVar get
-             6 -> liftM2 ETyped get get
-             7 -> liftM  EImplArg get
-             _ -> decodingError
-
-instance Binary Patt where
-  put (PApp f ps)  = putWord8 0 >> put (f,ps)
-  put (PVar   x)   = putWord8 1 >> put x
-  put (PAs x p)    = putWord8 2 >> put (x,p)
-  put PWild        = putWord8 3
-  put (PLit l)     = putWord8 4 >> put l
-  put (PImplArg p) = putWord8 5 >> put p
-  put (PTilde p)   = putWord8 6 >> put p
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM2 PApp get get
-             1 -> liftM  PVar get
-             2 -> liftM2 PAs get get
-             3 -> return PWild
-             4 -> liftM  PLit get
-             5 -> liftM  PImplArg get
-             6 -> liftM  PTilde get
-             _ -> decodingError
-
-instance Binary Equation where
-  put (Equ ps e) = put (ps,e)
-  get = liftM2 Equ get get
-
-instance Binary Instr where
-  put (CHECK_ARGS        n) = putWord8 0  >> put n
-  put (CASE     id       l) = putWord8 4  >> put (id,l)
-  put (CASE_LIT (LInt n) l) = putWord8 8  >> put (n,l)
-  put (CASE_LIT (LStr s) l) = putWord8 9  >> put (s,l)
-  put (CASE_LIT (LFlt d) l) = putWord8 10 >> put (d,l)
-  put (SAVE              n) = putWord8 12 >> put n
-  put (ALLOC             n) = putWord8 16 >> put n
-  put (PUT_CONSTR       id) = putWord8 20 >> put id
-  put (PUT_CLOSURE       l) = putWord8 24  >> put l
-  put (PUT_LIT    (LInt n)) = putWord8 28  >> put n
-  put (PUT_LIT    (LStr s)) = putWord8 29 >> put s
-  put (PUT_LIT    (LFlt d)) = putWord8 30 >> put d
-  put (SET    (HEAP     n)) = putWord8 32 >> put n
-  put (SET    (ARG_VAR  n)) = putWord8 33 >> put n
-  put (SET    (FREE_VAR n)) = putWord8 34 >> put n
-  put (SET    (GLOBAL  id)) = putWord8 35 >> put id
-  put (SET_PAD            ) = putWord8 36
-  put (PUSH_FRAME         ) = putWord8 40
-  put (PUSH   (HEAP     n)) = putWord8 44 >> put n
-  put (PUSH   (ARG_VAR  n)) = putWord8 45 >> put n
-  put (PUSH   (FREE_VAR n)) = putWord8 46 >> put n
-  put (PUSH   (GLOBAL  id)) = putWord8 47 >> put id
-  put (TUCK (HEAP     n) i) = putWord8 48 >> put (n,i)
-  put (TUCK (ARG_VAR  n) i) = putWord8 49 >> put (n,i)
-  put (TUCK (FREE_VAR n) i) = putWord8 50 >> put (n,i)
-  put (TUCK (GLOBAL  id) i) = putWord8 51 >> put (id,i)
-  put (EVAL (HEAP     n) RecCall) = putWord8 52 >> put n
-  put (EVAL (ARG_VAR  n) RecCall) = putWord8 53 >> put n
-  put (EVAL (FREE_VAR n) RecCall) = putWord8 54 >> put n
-  put (EVAL (GLOBAL  id) RecCall) = putWord8 55 >> put id
-  put (EVAL (HEAP     n) (TailCall a)) = putWord8 56 >> put n >> put a
-  put (EVAL (ARG_VAR  n) (TailCall a)) = putWord8 57 >> put n >> put a
-  put (EVAL (FREE_VAR n) (TailCall a)) = putWord8 58 >> put n >> put a
-  put (EVAL (GLOBAL  id) (TailCall a)) = putWord8 59 >> put id >> put a
-  put (EVAL (HEAP     n) UpdateCall) = putWord8 60 >> put n
-  put (EVAL (ARG_VAR  n) UpdateCall) = putWord8 61 >> put n
-  put (EVAL (FREE_VAR n) UpdateCall) = putWord8 62 >> put n
-  put (EVAL (GLOBAL  id) UpdateCall) = putWord8 63 >> put id
-  put (DROP n             ) = putWord8 64  >> put n
-  put (JUMP l             ) = putWord8 68  >> put l
-  put (FAIL               ) = putWord8 72
-  put (PUSH_ACCUM (LInt n)) = putWord8 76 >> put n
-  put (PUSH_ACCUM (LStr s)) = putWord8 77 >> put s
-  put (PUSH_ACCUM (LFlt d)) = putWord8 78 >> put d
-  put (POP_ACCUM          ) = putWord8 80
-  put (ADD                ) = putWord8 84
-  get = fail "Missing implementation for ‘get’ in the instance declaration for ‘Binary Instr’"
-
-instance Binary Type where
-  put (DTyp hypos cat exps) = put (hypos,cat,exps)
-  get = liftM3 DTyp get get get
-
-instance Binary BindType where
-  put Explicit = putWord8 0
-  put Implicit = putWord8 1
-  get = do tag <- getWord8
-           case tag of
-             0 -> return Explicit
-             1 -> return Implicit
-             _ -> decodingError
-
-instance Binary CncFun where
-  put (CncFun fun lins) = put fun >> putArray lins
-  get = liftM2 CncFun get getArray
-
-instance Binary CncCat where
-  put (CncCat s e labels) = do put (s,e)
-                               putArray labels
-  get = liftM3 CncCat get get getArray
-
-instance Binary Symbol where
-  put (SymCat n l)       = putWord8 0 >> put (n,l)
-  put (SymLit n l)       = putWord8 1 >> put (n,l)
-  put (SymVar n l)       = putWord8 2 >> put (n,l)
-  put (SymKS ts)         = putWord8 3 >> put ts
-  put (SymKP d vs)       = putWord8 4 >> put (d,vs)
-  put SymBIND            = putWord8 5
-  put SymSOFT_BIND       = putWord8 6
-  put SymNE              = putWord8 7
-  put SymSOFT_SPACE      = putWord8 8
-  put SymCAPIT           = putWord8 9
-  put SymALL_CAPIT       = putWord8 10
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM2 SymCat get get
-             1 -> liftM2 SymLit get get
-             2 -> liftM2 SymVar get get
-             3 -> liftM  SymKS  get
-             4 -> liftM2 (\d vs -> SymKP d vs) get get
-             5 -> return SymBIND
-             6 -> return SymSOFT_BIND
-             7 -> return SymNE
-             8 -> return SymSOFT_SPACE
-             9 -> return SymCAPIT
-             10-> return SymALL_CAPIT
-             _ -> decodingError
-
-instance Binary PArg where
-  put (PArg hypos fid) = put (map snd hypos,fid)
-  get = get >>= \(hypos,fid) -> return (PArg (zip (repeat fidVar) hypos) fid)
-
-instance Binary Production where
-  put (PApply ruleid args) = putWord8 0 >> put (ruleid,args)
-  put (PCoerce fcat)       = putWord8 1 >> put fcat
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM2 PApply  get get
-             1 -> liftM  PCoerce get
-             _ -> decodingError
-
-instance Binary Literal where
-  put (LStr s) = putWord8 0 >> put s
-  put (LInt i) = putWord8 1 >> put i
-  put (LFlt d) = putWord8 2 >> put d
-  get = do tag <- getWord8
-           case tag of
-             0 -> liftM  LStr get
-             1 -> liftM  LInt get
-             2 -> liftM  LFlt get
-             _ -> decodingError
-
-
-putArray :: (Binary e, IArray a e) => a Int e -> Put
-putArray a = do put (rangeSize $ bounds a) -- write the length
-                mapM_ put (elems a)        -- now the elems.
-
-getArray :: (Binary e, IArray a e) => Get (a Int e)
-getArray = do n  <- get                  -- read the length
-              xs <- replicateM n get     -- now the elems.
-              return (listArray (0,n-1) xs)
-
-putArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => a1 Int (a2 Int e) -> Put
-putArray2 a = do put (rangeSize $ bounds a) -- write the length
-                 mapM_ putArray (elems a)        -- now the elems.
-
-getArray2 :: (Binary e, IArray a1 (a2 Int e), IArray a2 e) => Get (a1 Int (a2 Int e))
-getArray2 = do n  <- get                       -- read the length
-               xs <- replicateM n getArray     -- now the elems.
-               return (listArray (0,n-1) xs)
-
-decodingError = fail "This file was compiled with different version of GF"

src/runtime/haskell/PGF/ByteCode.hs

@@ -1,89 +0,0 @@
-module PGF.ByteCode(Literal(..),
-                    CodeLabel, Instr(..), IVal(..), TailInfo(..),
-                    ppLit, ppCode, ppInstr
-                   ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-import PGF.CId
-import Text.PrettyPrint
-
-data Literal =
-   LStr String                      -- ^ string constant
- | LInt Int                         -- ^ integer constant
- | LFlt Double                      -- ^ floating point constant
- deriving (Eq,Ord,Show)
-
-type CodeLabel = Int
-
-data Instr
-  = CHECK_ARGS {-# UNPACK #-} !Int
-  | CASE CId  {-# UNPACK #-} !CodeLabel
-  | CASE_LIT Literal  {-# UNPACK #-} !CodeLabel
-  | SAVE {-# UNPACK #-} !Int
-  | ALLOC  {-# UNPACK #-} !Int
-  | PUT_CONSTR CId
-  | PUT_CLOSURE   {-# UNPACK #-} !CodeLabel
-  | PUT_LIT Literal
-  | SET IVal
-  | SET_PAD
-  | PUSH_FRAME
-  | PUSH IVal
-  | TUCK IVal {-# UNPACK #-} !Int
-  | EVAL IVal TailInfo
-  | DROP {-# UNPACK #-} !Int
-  | JUMP {-# UNPACK #-} !CodeLabel
-  | FAIL
-  | PUSH_ACCUM Literal
-  | POP_ACCUM
-  | ADD
-
-data IVal
-  = HEAP     {-# UNPACK #-} !Int
-  | ARG_VAR  {-# UNPACK #-} !Int
-  | FREE_VAR {-# UNPACK #-} !Int
-  | GLOBAL   CId
-  deriving Eq
-
-data TailInfo
-  = RecCall
-  | TailCall {-# UNPACK #-} !Int
-  | UpdateCall
-
-ppLit (LStr s) = text (show s)
-ppLit (LInt n) = int n
-ppLit (LFlt d) = double d
-
-ppCode :: Int -> [[Instr]] -> Doc
-ppCode l []       = empty
-ppCode l (is:iss) = ppLabel l <+> vcat (map ppInstr is) $$ ppCode (l+1) iss
-
-ppInstr (CHECK_ARGS    n) = text "CHECK_ARGS " <+> int n
-ppInstr (CASE id l      ) = text "CASE       " <+> ppCId id <+> ppLabel l
-ppInstr (CASE_LIT lit l ) = text "CASE_LIT   " <+> ppLit lit <+> ppLabel l
-ppInstr (SAVE          n) = text "SAVE       " <+> int n
-ppInstr (ALLOC         n) = text "ALLOC      " <+> int n
-ppInstr (PUT_CONSTR   id) = text "PUT_CONSTR " <+> ppCId id
-ppInstr (PUT_CLOSURE   l) = text "PUT_CLOSURE" <+> ppLabel l
-ppInstr (PUT_LIT lit    ) = text "PUT_LIT    " <+> ppLit lit
-ppInstr (SET           v) = text "SET        " <+> ppIVal v
-ppInstr (SET_PAD        ) = text "SET_PAD"
-ppInstr (PUSH_FRAME     ) = text "PUSH_FRAME"
-ppInstr (PUSH          v) = text "PUSH       " <+> ppIVal v
-ppInstr (EVAL       v ti) = text "EVAL       " <+> ppIVal v <+> ppTailInfo ti
-ppInstr (TUCK v n       ) = text "TUCK       " <+> ppIVal v <+> int n
-ppInstr (DROP n         ) = text "DROP       " <+> int n
-ppInstr (JUMP l         ) = text "JUMP       " <+> ppLabel l
-ppInstr (FAIL           ) = text "FAIL"
-ppInstr (PUSH_ACCUM  lit) = text "PUSH_ACCUM " <+> ppLit lit
-ppInstr (POP_ACCUM      ) = text "POP_ACCUM"
-ppInstr (ADD            ) = text "ADD"
-
-ppIVal (HEAP     n) = text "hp"  <> parens (int n)
-ppIVal (ARG_VAR  n) = text "stk" <> parens (int n)
-ppIVal (FREE_VAR n) = text "env" <> parens (int n)
-ppIVal (GLOBAL  id) = ppCId id
-
-ppTailInfo RecCall      = empty
-ppTailInfo (TailCall n) = text "tail" <> parens (int n)
-ppTailInfo UpdateCall   = text "update"
-
-ppLabel l = text (let s = show l in replicate (3-length s) '0' ++ s)