cleanup

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
@@ -31,12 +31,6 @@ data Argument
   | AMacro Ident
   deriving Show
 
-valCIdOpts :: String -> CId -> [Option] -> CId
-valCIdOpts flag def opts =
-  case [v | OFlag f (VId v) <- opts, f == flag] of
-    (v:_) -> mkCId v
-    _     -> def
-
 valIntOpts :: String -> Int -> [Option] -> Int
 valIntOpts flag def opts =
   case [v | OFlag f (VInt v) <- opts, f == flag] of
@@ -49,12 +43,6 @@ valStrOpts flag def opts =
     v:_ -> valueString v
     _   -> def
 
-maybeCIdOpts :: String -> a -> (CId -> a) -> [Option] -> a
-maybeCIdOpts flag def fn opts =
-  case [v | OFlag f (VId v) <- opts, f == flag] of
-    (v:_) -> fn (mkCId v)
-    _     -> def
-
 maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
 maybeIntOpts flag def fn opts =
   case [v | OFlag f (VInt v) <- opts, f == flag] of

src/compiler/GF/Command/CommandInfo.hs

@@ -3,7 +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 PGF(mkStr,unStr,showExpr)
+import PGF2(mkStr,unStr,showExpr)
 
 data CommandInfo m = CommandInfo {
   exec     :: [Option] -> CommandArguments -> m CommandOutput,

src/compiler/GF/Command/Commands.hs

@@ -1,12 +1,12 @@
 {-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 module GF.Command.Commands (
-  PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
+  HasPGF(..),pgfCommands,
   options,flags,
   ) where
 import Prelude hiding (putStrLn)
 
-import PGF
+import PGF2
-import PGF.Internal(writePGF)
+import PGF2.Internal(writePGF)
 
 import GF.Compile.Export
 import GF.Compile.ToAPI
@@ -24,33 +24,25 @@ 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 Debug.Trace
+import Control.Monad(mplus)
 
+class (Functor m,Monad m,MonadSIO m) => HasPGF m where getPGF :: m (Maybe PGF)
 
-data PGFEnv = Env {pgf::Maybe PGF,mos::Map.Map Language Morpho}
+instance (Monad m,HasPGF m) => TypeCheckArg m where
+  typeCheckArg e = do mb_pgf <- getPGF
+                      case mb_pgf of
+                        Just pgf -> either fail
+                                           (return . fst)
+                                           (inferExpr pgf e)
+                        Nothing  -> fail "Import a grammar before using this command"
 
-pgfEnv mb_pgf = Env mb_pgf mos
+pgfCommands :: HasPGF m => Map.Map String (CommandInfo m)
-  where mos = case mb_pgf of
-                Just pgf -> Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
-                Nothing  -> Map.empty
-
-class (Functor m,Monad 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 . render . ppTcError)
-                                          (return . fst)
-                                          (inferExpr gr 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",
@@ -63,7 +55,7 @@ pgfCommands = Map.fromList [
        "by the view flag. The target format is png, unless overridden by the",
        "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick)."
        ],
-     exec = needPGF $ \ opts arg pgf mos -> do
+     exec = needPGF $ \ opts arg pgf -> do
          let es = toExprs arg
          let langs = optLangs pgf opts
          if isOpt "giza" opts
@@ -75,7 +67,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
@@ -108,16 +100,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  = needPGF $ \opts ts pgf mos -> case opts of
+     exec  = needPGF $ \opts ts pgf -> do
-               _ | isOpt "raw" opts ->
+               concr <- optLang pgf opts
-                    return . fromString .
+               case opts of
-                    unlines . map (unwords . map (concat . intersperse "+")) .
+                 _ | isOpt "raw" opts ->
-                    map (getClitics (isInMorpho (optMorpho pgf mos opts)) (optClitics opts)) .
+                       return . fromString .
-                    concatMap words $ toStrings ts
+                       unlines . map (unwords . map (concat . intersperse "+")) .
-               _ ->
+                       map (getClitics (not . null . lookupMorpho concr) (optClitics opts)) .
-                    return . fromStrings .
+                       concatMap words $ toStrings ts
-                    getCliticsText (isInMorpho (optMorpho pgf mos opts)) (optClitics opts) .
+                 _ -> return . fromStrings .
-                    concatMap words $ toStrings ts,
+                      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")
@@ -151,10 +144,11 @@ pgfCommands = Map.fromList [
        ("file","the file to be converted (suffix .gfe must be given)"),
        ("lang","the language in which to parse")
        ],
-     exec = needPGF $ \ opts _ pgf mos -> do
+     exec = needPGF $ \opts _ pgf -> do
        let file = optFile opts
        let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
-       let conf = configureExBased pgf (optMorpho pgf mos 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')),
@@ -175,21 +169,19 @@ 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,",
+       "all metavariables in the tree. The generation can be biased by probabilities",
-       "given in a file in the -probs flag."
+       "if the grammar was compiled with option -probs"
        ],
      flags = [
        ("cat","generation category"),
        ("lang","uses only functions that have linearizations in all these languages"),
-       ("number","number of trees generated"),
+       ("number","number of trees generated")
-       ("depth","the maximum generation depth")
        ],
-     exec = needPGF $ \ opts arg pgf mos -> do
+     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)
+                   Just ex -> generateRandomFrom gen pgf ex
-                   Nothing -> generateRandomDepth     gen pgf (optType pgf opts) (Just dp)
+                   Nothing -> generateRandom     gen pgf (optType pgf opts)
        returnFromExprs $ take (optNum opts) ts
      }),
 
@@ -197,29 +189,25 @@ pgfCommands = Map.fromList [
      longname = "generate_trees",
      synopsis = "generates a list of trees, by default exhaustive",
      explanation = unlines [
-       "Generates all trees of a given category. By default, ",
+       "Generates all trees of a given category.",
-       "the depth is limited to 4, but this can be changed by a flag.",
        "If a Tree argument is given, the command completes the Tree with values",
        "to all metavariables in the tree."
        ],
      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 = needPGF $ \opts arg pgf mos -> do
+     exec = needPGF $ \opts arg pgf -> do
-       let dp = valIntOpts "depth" 4 opts
        let ts = case mexp (toExprs arg) of
-                  Just ex -> generateFromDepth pgf ex (Just dp)
+                  Just ex -> generateAllFrom pgf ex
-                  Nothing -> generateAllDepth pgf (optType pgf opts) (Just dp)
+                  Nothing -> generateAll     pgf (optType pgf opts)
-       returnFromExprs $ take (optNumInf opts) ts
+       returnFromExprs $ take (optNumInf opts) (map fst ts)
      }),
 
   ("i", emptyCommandInfo {
@@ -253,22 +241,17 @@ pgfCommands = Map.fromList [
      longname = "linearize",
      synopsis = "convert an abstract syntax expression to string",
      explanation = unlines [
-       "Shows the linearization of a Tree by the grammars in scope.",
+       "Shows the linearization of a tree by the grammars in scope.",
        "The -lang flag can be used to restrict this to fewer languages.",
        "A sequence of string operations (see command ps) can be given",
        "as options, and works then like a pipe to the ps command, except",
-       "that it only affect the strings, not e.g. the table labels.",
+       "that it only affect the strings, not e.g. the table labels."
-       "These can be given separately to each language with the unlexer flag",
-       "whose results are prepended to the other lexer flags. The value of the",
-       "unlexer flag is a space-separated list of comma-separated string operation",
-       "sequences; see example."
        ],
      examples = [
        mkEx "l -lang=LangSwe,LangNor no_Utt   -- linearize tree to LangSwe and LangNor",
-       mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
+       mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table"
-       mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
        ],
-     exec = needPGF $ \ opts ts pgf 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"),
@@ -279,8 +262,7 @@ pgfCommands = Map.fromList [
        ("treebank","show the tree and tag linearizations with language names")
        ] ++ stringOpOptions,
      flags = [
-       ("lang","the languages of linearization (comma-separated, no spaces)"),
+       ("lang","the languages of linearization (comma-separated, no spaces)")
-       ("unlexer","set unlexers separately to each language (space-separated)")
        ]
      }),
 
@@ -291,18 +273,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  = needPGF $ \opts ts pgf mos -> case opts of
+     exec  = needPGF $ \opts ts pgf -> do
-               _ | isOpt "missing" opts ->
+               concr <- optLang pgf opts
-                    return . fromString . unwords .
+               case opts of
-                    morphoMissing (optMorpho pgf mos opts) .
+                 _ | isOpt "missing" opts ->
-                    concatMap words $ toStrings ts
+                      return . fromString . unwords .
-               _ | isOpt "known" opts ->
+                      morphoMissing concr .
-                    return . fromString . unwords .
+                      concatMap words $ toStrings ts
-                    morphoKnown (optMorpho pgf mos opts) .
+                 _ | isOpt "known" opts ->
-                    concatMap words $ toStrings ts
+                      return . fromString . unwords .
-               _ -> return . fromString . unlines .
+                      morphoKnown concr .
-                    map prMorphoAnalysis . concatMap (morphos pgf mos opts) .
+                      concatMap words $ toStrings ts
-                    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)")
        ],
@@ -316,8 +300,8 @@ pgfCommands = Map.fromList [
      longname = "morpho_quiz",
      synopsis = "start a morphology quiz",
      syntax   = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
-     exec = needPGF $ \ opts arg pgf mos -> do
+     exec = needPGF $ \ opts arg pgf -> do
-         let lang = optLang pgf opts
+         lang <- optLang pgf opts
          let typ  = optType pgf opts
          let mt = mexp (toExprs arg)
          restricted $ morphologyQuiz mt pgf lang typ
@@ -336,22 +320,13 @@ 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.",
+       "See also the ps command for lexing and character encoding."
-       "",
-       "The -openclass flag is experimental and allows some robustness in ",
-       "the parser. For example if -openclass=\"A,N,V\" is given, the parser",
-       "will accept unknown adjectives, nouns and verbs with the resource grammar."
        ],
-     exec = needPGF $ \opts ts pgf mos ->
+     exec = needPGF $ \opts ts pgf ->
               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)"),
+       ("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")
        ]
      }),
 
@@ -374,7 +349,7 @@ pgfCommands = Map.fromList [
         " " ++ opt ++ "\t\t" ++ expl |
            ((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
        ]),
-     exec  = needPGF $ \opts _ pgf mos -> prGrammar pgf mos opts,
+     exec  = needPGF $ \opts _ pgf -> prGrammar pgf opts,
      flags = [
        --"cat",
        ("file",   "set the file name when printing with -pgf option"),
@@ -410,7 +385,7 @@ pgfCommands = Map.fromList [
      examples = [
        mkEx "pt -compute (plus one two)                               -- compute value"
        ],
-     exec = needPGF $ \opts arg pgf mos ->
+     exec = needPGF $ \opts arg pgf ->
             returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg,
      options = treeOpOptions undefined{-pgf-},
      flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
@@ -430,7 +405,7 @@ pgfCommands = Map.fromList [
        ("lines","return the list of lines, instead of the singleton of all contents"),
        ("tree","convert strings into trees")
        ],
-     exec = needPGF $ \ opts _ pgf mos -> do
+     exec = needPGF $ \ opts _ pgf -> do
        let file = valStrOpts "file" "_gftmp" opts
        let exprs []         = ([],empty)
            exprs ((n,s):ls) | null s
@@ -439,7 +414,7 @@ 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
@@ -457,38 +432,13 @@ pgfCommands = Map.fromList [
      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 arg pgf mos -> do
-         let ts = toExprs arg
-         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,
-     options = [
-       ("v","show all trees with their probability scores")
-       ],
-     examples = [
-      mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result"
-      ]
-     }),
-
   ("tq", emptyCommandInfo {
      longname = "translation_quiz",
      syntax   = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
      synopsis = "start a translation quiz",
-     exec = needPGF $ \ opts arg pgf mos -> do
+     exec = needPGF $ \ opts arg pgf -> do
-         let from = optLangFlag "from" pgf opts
+         from <- optLangFlag "from" pgf opts
-         let to   = optLangFlag "to" pgf opts
+         to   <- optLangFlag "to"   pgf opts
          let typ  = optType pgf opts
          let mt   = mexp (toExprs arg)
          restricted $ translationQuiz mt pgf from to typ
@@ -522,7 +472,7 @@ pgfCommands = Map.fromList [
        "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
        "See also 'vp -showdep' for another visualization of dependencies." 
        ],
-     exec = needPGF $ \ opts arg pgf mos -> do
+     exec = needPGF $ \ opts arg pgf -> do
          let absname = abstractName pgf
          let es = toExprs arg
          let debug = isOpt "v" opts
@@ -535,8 +485,8 @@ pgfCommands = Map.fromList [
          mclab <- case cnclabels of
            "" -> return Nothing
            _  -> (Just . getCncDepLabels) `fmap` restricted (readFile cnclabels)
-         let lang = optLang pgf opts
+         concr <- optLang pgf opts
-         let grphs = map (graphvizDependencyTree outp debug mlab mclab pgf lang) es
+         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"
@@ -582,9 +532,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 = needPGF $ \ opts arg pgf mos -> do
+     exec = needPGF $ \opts arg pgf -> do
-         let es = toExprs arg
+         let es        = toExprs arg
-         let lang = optLang pgf opts
          let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
                                           noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
                                           noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
@@ -597,10 +546,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
@@ -647,7 +597,7 @@ pgfCommands = Map.fromList [
        "flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
        "With option -mk, use for showing library style function names of form 'mkC'."
        ],
-     exec = needPGF $ \ opts arg pgf mos ->
+     exec = needPGF $ \opts arg pgf ->
       let es = toExprs arg in
        if isOpt "mk" opts
        then return $ fromString $ unlines $ map (tree2mk pgf) es
@@ -659,7 +609,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
@@ -694,7 +644,7 @@ pgfCommands = Map.fromList [
        "If a whole expression is given it prints the expression with refined",
        "metavariables and the type of the expression."
        ],
-     exec = needPGF $ \opts arg pgf mos -> do
+     exec = needPGF $ \opts arg pgf -> do
        case toExprs arg of
          [e] -> case unApp e of
                   Just (id, []) -> case functionType pgf id of
@@ -702,7 +652,7 @@ pgfCommands = Map.fromList [
                                                    putStrLn ("Probability: "++show (treeProbability pgf e))
                                                    return void
                                      Nothing -> case categoryContext pgf id of
-                                                  Just hypos -> do putStrLn ("cat "++showCId id++if null hypos then "" else ' ':showContext [] hypos)
+                                                  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 ()
@@ -712,7 +662,7 @@ pgfCommands = Map.fromList [
                                                   Nothing    -> do putStrLn ("unknown category of function identifier "++show id)
                                                                    return void
                   _             -> case inferExpr pgf e of
-                                     Left tcErr   -> error $ render (ppTcError tcErr)
+                                     Left err     -> error err
                                      Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
                                                         putStrLn ("Type:        "++showType [] ty)
                                                         putStrLn ("Probability: "++show (treeProbability pgf e))
@@ -724,14 +674,12 @@ pgfCommands = Map.fromList [
   ]
  where
    needPGF exec opts ts = do
-     Env mb_pgf mos <- getPGFEnv
+     mb_pgf <- getPGF
      case mb_pgf of
-       Just pgf -> liftSIO $ exec opts ts pgf mos
+       Just pgf -> liftSIO $ exec opts ts pgf
        _ -> fail "Import a grammar before using this command"
 
-   par pgf opts s = [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
+   par pgf opts s = [parse concr (optType pgf opts) s | concr <- optLangs pgf opts]
-     where
-       dp = valIntOpts "depth" 4 opts
 
    fromParse opts = foldr (joinPiped . fromParse1 opts) void
 
@@ -740,49 +688,39 @@ pgfCommands = Map.fromList [
        jA (Exprs es1) (Exprs es2) = Exprs (es1++es2)
        -- ^ fromParse1 always output Exprs
 
-   fromParse1 opts (s,(po,bs))
+   fromParse1 opts (s,po) =
-     | isOpt "bracket" opts = pipeMessage (showBracketedString bs)
-     | otherwise            =
          case po of
-           ParseOk ts      -> fromExprs ts
+           ParseOk ts      -> fromExprs (map fst ts)
-           ParseFailed i   -> pipeMessage $ "The parser failed at token "
+           ParseFailed i _ -> pipeMessage $ "The parser failed at token "
                                              ++ show i ++": "
                                              ++ show (words s !! max 0 (i-1))
                                           -- ++ " in " ++ show s
            ParseIncomplete -> pipeMessage "The sentence is not complete"
-           TypeError errs  ->
-             pipeMessage . render $
-               "The parsing is successful but the type checking failed with error(s):"
-               $$ nest 2 (vcat (map (ppTcError . snd) errs))
 
-   optLins pgf opts ts = case opts of
+   optLins pgf opts ts = concatMap (optLin pgf opts) ts
-     _ | isOpt "groups" opts ->
-       concatMap snd $ groupResults
-         [[(lang, s) | lang <- optLangs pgf opts,s <- linear pgf opts lang t] | t <- ts]
-     _ -> concatMap (optLin pgf opts) ts
    optLin pgf opts t =
      case opts of
        _ | isOpt "treebank" opts && isOpt "chunks" opts ->
-         (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
+         (abstractName pgf ++ ": " ++ showExpr [] t) :
-         [showCId lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts]
+         [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) :
+         (abstractName pgf ++ ": " ++ showExpr [] t) :
-         [showCId lang ++ ": " ++ s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
+         [concreteName concr ++ ": " ++ s | concr <- optLangs pgf opts, s<-linear opts concr t]
        _ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t   
-       _ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
+       _ -> [s | concr <- optLangs pgf opts, s <- linear opts concr t]
    linChunks pgf opts t = 
-     [(lang, unwords (intersperse "<+>" (map (unlines . linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts]
+     [(concreteName concr, unwords (intersperse "<+>" (map (unlines . linear opts concr) (treeChunks t)))) | concr <- optLangs pgf opts]
 
-   linear :: PGF -> [Option] -> CId -> Expr -> [String]
+   linear :: [Option] -> Concr -> Expr -> [String]
-   linear pgf opts lang = let unl = unlex opts lang in case opts of
+   linear opts concr = case opts of
-       _ | isOpt "all"     opts -> concat . -- intersperse [[]] .
+       _ | isOpt "all"     opts -> concat .
-                                   map (map (unl . snd)) . tabularLinearizes pgf lang
+                                   map (map snd) . tabularLinearizeAll concr
        _ | isOpt "list"    opts -> (:[]) . commaList . concat .
-                                   map (map (unl . snd)) . tabularLinearizes pgf lang
+                                   map (map snd) . tabularLinearizeAll concr
-       _ | isOpt "table"   opts -> concat . -- intersperse [[]] .
+       _ | isOpt "table"   opts -> concat .
-                    map (map (\(p,v) -> p+++":"+++unl v)) . tabularLinearizes pgf lang
+                                    map (map (\(p,v) -> p+++":"+++v)) . tabularLinearizeAll concr
-       _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize pgf lang
+       _ | isOpt "bracket" opts -> (:[]) . unwords . map showBracketedString . bracketedLinearize concr
-       _                        -> (:[]) . unl . linearize pgf lang
+       _                        -> (:[]) . linearize concr
 
    -- replace each non-atomic constructor with mkC, where C is the val cat
    tree2mk pgf = showExpr [] . t2m where
@@ -791,61 +729,38 @@ pgfCommands = Map.fromList [
                _                   -> t
      mk f = case functionType pgf f of
               Just ty -> let (_,cat,_) = unType ty
-                         in mkCId ("mk" ++ showCId cat)
+                         in "mk" ++ cat
               Nothing -> f
 
-   unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ----
-
-   getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
-     lexs -> case lookup lang
-               [(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
-       Just le -> chunks ',' le
-       _ -> []
-
    commaList [] = []
    commaList ws = concat $ head ws : map (", " ++) (tail ws)
 
--- Proposed logic of coding in unlexing:
---   - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used.
---   - If lang has flag coding=utf8, -to_utf8 is ignored.
---   - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first.
--- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
-{-
-   unlexx pgf opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ----
-     optsC = case lookConcrFlag pgf (mkCId lang) (mkCId "coding") of
-       Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts
-       Just (LStr other) | isOpt "to_utf8" opts ->
-                      let cod = ("from_" ++ other)
-                      in cod : filter (/=cod) (map prOpt opts)
-       _ -> map prOpt opts
--}
-
    optLang  = optLangFlag "lang"
    optLangs = optLangsFlag "lang"
 
-   optLangsFlag f pgf opts = case valStrOpts f "" opts of
+   optLangFlag flag pgf opts =
-     "" -> languages pgf
+     case optLangsFlag flag pgf opts of
-     lang -> map (completeLang pgf) (chunks ',' lang)
+       []     -> fail "no language specified"
-   completeLang pgf la = let cla = (mkCId la) in
+       (l:ls) -> return l
-     if elem cla (languages pgf)
+
-       then cla
+   optLangsFlag flag pgf opts =
-       else (mkCId (showCId (abstractName pgf) ++ la))
+     case valStrOpts flag "" opts of
+       ""  -> Map.elems langs
+       str -> mapMaybe (completeLang pgf) (chunks ',' str)
+     where
+       langs = languages pgf
+
+       completeLang pgf la =
+         mplus (Map.lookup la                       langs)
+               (Map.lookup (abstractName pgf ++ la) langs)
 
-   optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [wildCId]
-{-
-   optProbs opts pgf = case valStrOpts "probs" "" opts of
-     ""   -> return pgf
-     file -> do
-       probs <- restricted $ readProbabilitiesFromFile file pgf
-       return (setProbabilities probs pgf)
--}
    optFile opts = valStrOpts "file" "_gftmp" opts
 
    optType pgf opts =
      let readOpt str = case readType str of
                          Just ty -> case checkType pgf ty of
-                                      Left tcErr -> error $ render (ppTcError tcErr)
+                                      Left err -> error err
-                                      Right ty   -> ty
+                                      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
@@ -858,35 +773,31 @@ pgfCommands = Map.fromList [
      [] -> pipeMessage "no trees found"
      _  -> fromExprs es
 
-   prGrammar pgf mos opts
+   prGrammar pgf opts
      | isOpt "pgf"      opts = do
-          let outfile = valStrOpts "file" (showCId (abstractName pgf) ++ ".pgf") opts
+          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 "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 (morpho mos "" prFullFormLexicon) $ optLangs pgf opts
+     | isOpt "fullform" opts = return $ fromString $ concatMap prFullFormLexicon $ optLangs pgf opts
-     | isOpt "langs"    opts = return $ fromString $ unwords $ map showCId $ languages pgf
+     | isOpt "langs"    opts = return $ fromString $ unwords $ Map.keys $ languages pgf
 
-     | isOpt "lexc"     opts = return $ fromString $ concatMap (morpho mos "" prLexcLexicon) $ optLangs pgf opts
+     | isOpt "lexc"     opts = return $ fromString $ concatMap prLexcLexicon $ optLangs pgf opts
-     | isOpt "missing"  opts = return $ fromString $ unlines $ [unwords (showCId la:":":[showCId f | f <- functions pgf, not (hasLinearization pgf la f)]) |
+     | isOpt "missing"  opts = return $ fromString $ unlines $ [unwords (concreteName concr:":":[f | f <- functions pgf, not (hasLinearization concr f)]) |
-                                                                  la <- optLangs pgf opts]
+                                                                  concr <- optLangs pgf opts]
-     | isOpt "words" opts = return $ fromString $ concatMap (morpho mos "" prAllWords) $ 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
 
-   showFun pgf id ty = kwd++" "++showCId id ++ " : " ++ showType [] ty
+   showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
                        where
                          kwd | functionIsDataCon pgf id = "data"
                              | otherwise                = "fun"
 
-   morphos pgf mos opts s =
+   morphos pgf opts s =
-     [(s,morpho mos [] (\mo -> lookupMorpho mo s) la) | la <- optLangs pgf opts]
+     [(s,lookupMorpho concr s) | concr <- optLangs pgf opts]
-
-   morpho mos z f la = maybe z f $ Map.lookup la mos
-
-   optMorpho pgf mos opts = morpho mos (error "no morpho") id (head (optLangs pgf opts))
 
    optClitics opts = case valStrOpts "clitics" "" opts of
      "" -> []
@@ -899,18 +810,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
@@ -919,28 +840,28 @@ morphologyQuiz mex pgf ig typ = do
 infinity :: Int
 infinity = 256
 
-prLexcLexicon :: Morpho -> String
+prLexcLexicon :: Concr -> String
-prLexcLexicon mo =
+prLexcLexicon concr =
-  unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w  ++ " # ;" | (w,lps) <- morpho, (l,p) <- lps] ++ ["END"]
+  unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w  ++ " # ;" | (w,lps) <- morpho, (l,p,_) <- lps] ++ ["END"]
  where
-  morpho = fullFormLexicon mo
+  morpho = fullFormLexicon concr
-  prLexc l p = showCId l ++ concat (mkTags (words p))
+  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]
+  multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p,_) <- lps]
 
-prFullFormLexicon :: Morpho -> String
+prFullFormLexicon :: Concr -> String
-prFullFormLexicon mo =
+prFullFormLexicon concr =
-  unlines (map prMorphoAnalysis (fullFormLexicon mo))
+  unlines (map prMorphoAnalysis (fullFormLexicon concr))
 
-prAllWords :: Morpho -> String
+prAllWords :: Concr -> String
-prAllWords mo =
+prAllWords concr =
-  unwords [w | (w,_) <- fullFormLexicon mo]
+  unwords [w | (w,_) <- fullFormLexicon concr]
 
 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

src/compiler/GF/Command/Commands2.hs

@@ -1,822 +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)
-
-
-data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr}
-
-pgfEnv pgf = Env (Just pgf) (languages pgf)
-emptyPGFEnv = Env Nothing Map.empty
-
-class (Monad 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
-           _ -> 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
-           _ -> 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

@@ -15,7 +15,7 @@ import GF.Text.Pretty
 import GF.Text.Transliterations
 import GF.Text.Lexing(stringOp,opInEnv)
 
-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
 
@@ -101,9 +101,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",
@@ -175,12 +173,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",
@@ -228,7 +220,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)"),
@@ -253,19 +244,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

src/compiler/GF/Command/Importing.hs

@@ -1,7 +1,7 @@
 module GF.Command.Importing (importGrammar, importSource) where
 
-import PGF
+import PGF2
-import PGF.Internal(unionPGF)
+import PGF2.Internal(unionPGF)
 
 import GF.Compile
 import GF.Compile.Multi (readMulti)

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
 import GF.Infra.UseIO(putStrLnE)
+import PGF2
 
 import Control.Monad(when)
 import qualified Data.Map as Map

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

@@ -4,15 +4,15 @@ module GF.Command.TreeOperations (
   treeChunks
   ) where
 
-import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
+import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unapply,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))),

src/compiler/GF/Compile.hs

@@ -22,7 +22,7 @@ import Data.List(nub)
 import Data.Time(UTCTime)
 import GF.Text.Pretty(render,($$),(<+>),nest)
 
-import PGF(PGF,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'.

src/compiler/GF/Compile/CFGtoPGF.hs

@@ -6,8 +6,8 @@ import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.Compile.OptimizePGF
 
-import PGF
+import PGF2
-import PGF.Internal
+import PGF2.Internal
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -20,22 +20,22 @@ import Data.Maybe(fromMaybe)
 -- the compiler ----------
 --------------------------
 
-cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map CId Double -> 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")
+   aname = name ++ "Abs"
-   cname = mkCId name
+   cname = name
 
-cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map CId Double -> B s AbstrInfo
+cf2abstr :: (?builder :: Builder s) => ParamCFG -> Map.Map Fun Double -> B s AbstrInfo
 cf2abstr cfg probs = newAbstr aflags acats afuns
   where
-    aflags = [(mkCId "startcat", LStr (fst (cfgStartCat cfg)))]
+    aflags = [("startcat", LStr (fst (cfgStartCat cfg)))]
 
     acats  = [(c', [], toLogProb (fromMaybe 0 (Map.lookup c' probs))) | cat <- allCats' cfg, let c' = cat2id cat]
-    afuns  = [(f', dTyp [hypo Explicit wildCId (dTyp [] (cat2id c) []) | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)) [], 0, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs)))
+    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]
 
@@ -53,12 +53,12 @@ cf2abstr cfg probs = newAbstr aflags acats afuns
 
     toLogProb = realToFrac . negate . log
 
-    cat2id = mkCId . fst
+    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 (mkCId (fst (cfgStartCat cfg))) else id)
+           (if flag optOptimizePGF opts then optimizePGF (fst (cfgStartCat cfg)) else id)
                 (lindefsrefs,lindefsrefs,IntMap.toList productions,cncfuns,sequences,cnccats)
   in newConcr abstr [] []
               lindefs' linrefs'
@@ -74,7 +74,7 @@ cf2concr opts abstr cfg =
                                map mkSequence rules)
     sequences  = Set.toList sequences0
 
-    idFun = (wildCId,[Set.findIndex idSeq 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 = reverse cncfuns0
@@ -100,11 +100,11 @@ cf2concr opts abstr cfg =
         convertSymbol d (Terminal t)        = (d,  SymKS t)
 
     mkCncCat fid (cat,n)
-      | cat == "Int"    = (fid, (mkCId cat, fidInt,    fidInt,    lbls))
+      | cat == "Int"    = (fid, (cat, fidInt,    fidInt,    lbls))
-      | cat == "Float"  = (fid, (mkCId cat, fidFloat,  fidFloat,  lbls))
+      | cat == "Float"  = (fid, (cat, fidFloat,  fidFloat,  lbls))
-      | cat == "String" = (fid, (mkCId cat, fidString, fidString, lbls))
+      | cat == "String" = (fid, (cat, fidString, fidString, lbls))
       | otherwise       = let fid' = fid+n+1
-                          in fid' `seq` (fid', (mkCId cat, 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 ) =
@@ -120,7 +120,7 @@ cf2concr opts abstr cfg =
         Nothing  -> IntMap.insert fid [prod]     prods
 
     cat2fid cat p =
-      case [start | (cat',start,_,_) <- cnccats, mkCId cat == cat'] of
+      case [start | (cat',start,_,_) <- cnccats, cat == cat'] of
         (start:_) -> fid+p
         _         -> error "cat2fid"
 
@@ -133,5 +133,5 @@ cf2concr opts abstr cfg =
 mkRuleName rule =
   case ruleName rule of
 	CFObj n _ -> n
-	_         -> wildCId
+	_         -> "_"
 

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 PGF2
---import PGF.Probabilistic
---import PGF.Morphology
---import GF.Compile.ToAPI
-
 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
+    ws <- case parse lang typ ex of
-      ParseFailed _ -> do
+      ParseFailed _ _ -> do
-        let ws = morphoMissing morpho (words ex)
         appv ("WARNING: cannot parse example " ++ ex) 
-        case ws of
-          [] -> return ()
-          _  -> appv ("  missing words: " ++ unwords ws)
-        return ws
-      TypeError _ ->
         return []
       ParseIncomplete ->
         return []
       ParseOk ts ->
-        case rank ts of
+        case ts of
           (t:tt) -> do
             if null tt 
               then return ()
               else appv ("WARNING: ambiguous example " ++ ex) 
-            appn t 
+            appn (printExp conf (fst t))
-            mapM_ (appn . ("  --- " ++)) tt
+            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_pgf :: PGF,
-  resource_morpho :: Morpho,
   verbose  :: Bool,
-  language :: Language,
+  language :: Concr,
-  printExp :: Tree -> String
+  printExp :: Expr -> String
   }
 
-configureExBased :: PGF -> Morpho -> Language -> (Tree -> String) -> ExConfiguration
+configureExBased :: PGF -> Concr -> (Expr -> String) -> ExConfiguration
-configureExBased pgf morpho lang pr = ExConf pgf morpho False lang pr
+configureExBased pgf concr pr = ExConf pgf False concr pr
 

src/compiler/GF/Compile/GenerateBC.hs

@@ -4,7 +4,7 @@ module GF.Compile.GenerateBC(generateByteCode) where
 import GF.Grammar
 import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
 import GF.Data.Operations
-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)

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -13,8 +13,9 @@ module GF.Compile.GeneratePMCFG
     (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
     ) where
 
---import PGF.CId
+import qualified PGF2 as PGF2
-import PGF.Internal as PGF(CId,Symbol(..),fidVar)
+import qualified PGF2.Internal as PGF2
+import PGF2.Internal(Symbol(..),fidVar)
 
 import GF.Infra.Option
 import GF.Grammar hiding (Env, mkRecord, mkTable)
@@ -68,7 +69,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]
@@ -92,7 +93,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)
 
@@ -102,11 +103,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)) 
+addPMCFG opts gr cenv opath am cm seqs id (CncCat mty@(Just (L _ lincat)) 
-                                                             mdef@(Just (L loc1 def))
+                                                  mdef@(Just (L loc1 def))
-                                                             mref@(Just (L loc2 ref))
+                                                  mref@(Just (L loc2 ref))
-                                                             mprn
+                                                  mprn
-                                                             Nothing) = do
+                                                  Nothing) = do
   let pcat = protoFCat gr (am,id) lincat
       pvar = protoFCat gr (MN identW,cVar) typeStr
 
@@ -131,7 +132,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'
@@ -157,7 +158,7 @@ convert opts gr cenv loc term ty@(_,val) pargs =
             args = map Vr vars
             vars = map (\(bt,x,t) -> x) context
 
-pgfCncCat :: SourceGrammar -> CId -> Type -> Int -> (CId,Int,Int,[String])
+pgfCncCat :: SourceGrammar -> PGF2.Cat -> Type -> Int -> (PGF2.Cat,Int,Int,[String])
 pgfCncCat gr id lincat index =
   let ((_,size),schema) = computeCatRange gr lincat
   in ( id
@@ -474,7 +475,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

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -18,7 +18,7 @@ import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
 import GF.Infra.Option(optionsPGF)
-import PGF.Internal(Literal(..))
+import PGF2.Internal(Literal(..))
 import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
 import GF.Grammar.Canonical as C
 import Debug.Trace

src/compiler/GF/Compile/OptimizePGF.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE BangPatterns #-}
 module GF.Compile.OptimizePGF(optimizePGF) where
 
-import PGF(mkCId)
+import PGF2(Cat,Fun)
-import PGF.Internal
+import PGF2.Internal
 import Data.Array.ST
 import Data.Array.Unboxed
 import qualified Data.Map as Map
@@ -15,19 +15,19 @@ import Control.Monad.ST
 type ConcrData = ([(FId,[FunId])],          -- ^ Lindefs
                   [(FId,[FunId])],          -- ^ Linrefs
                   [(FId,[Production])],     -- ^ Productions
-                  [(CId,[SeqId])],          -- ^ Concrete functions   (must be sorted by Fun)
+                  [(Fun,[SeqId])],          -- ^ Concrete functions   (must be sorted by Fun)
                   [[Symbol]],               -- ^ Sequences            (must be sorted)
-                  [(CId,FId,FId,[String])]) -- ^ Concrete categories
+                  [(Cat,FId,FId,[String])]) -- ^ Concrete categories
 
-optimizePGF :: CId -> ConcrData -> ConcrData
+optimizePGF :: Cat -> ConcrData -> ConcrData
 optimizePGF startCat = topDownFilter startCat . bottomUpFilter
 
-cidString = mkCId "String"
+catString = "String"
-cidInt    = mkCId "Int"
+catInt    = "Int"
-cidFloat  = mkCId "Float"
+catFloat  = "Float"
-cidVar    = mkCId "__gfVar"
+catVar    = "__gfVar"
-                         
+
-topDownFilter :: CId -> ConcrData -> ConcrData
+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')))
@@ -43,10 +43,10 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
       (sequences',cncfuns') = env3
   in (lindefs',linrefs',prods',mkSetArray cncfuns',mkSetArray  sequences',cnccats')
   where
-    cncfuns_array   = listArray (0,length cncfuns-1)   cncfuns   :: Array FunId (CId, [SeqId])
+    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,cidVar) :  [(fid,cat) | (cat,start,end,lbls) <- cnccats,
+    fid2catMap = IntMap.fromList ((fidVar,catVar) :  [(fid,cat) | (cat,start,end,lbls) <- cnccats,
                                                                   fid <- [start..end]])
 
     fid2cat fid =
@@ -76,17 +76,17 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
     -- 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 CId [LIndex]
+    closure :: Map.Map Cat [Int]
     closure = runST $ do
       set <- initSet
-      addLitCat cidString set
+      addLitCat catString set
-      addLitCat cidInt    set
+      addLitCat catInt    set
-      addLitCat cidFloat  set
+      addLitCat catFloat  set
-      addLitCat cidVar    set
+      addLitCat catVar    set
       closureSet set starts
       doneSet set
       where
-        initSet :: ST s (Map.Map CId (STUArray s LIndex LIndex))
+        initSet :: ST s (Map.Map Cat (STUArray s Int Int))
         initSet =
           fmap Map.fromList $ sequence
                         [fmap ((,) cat) (newArray (0,length lbls-1) (-1))
@@ -109,7 +109,7 @@ topDownFilter startCat (lindefs,linrefs,prods,cncfuns,sequences,cnccats) =
                                  else closureSet set xs
             Nothing      -> error "unknown cat"
 
-        doneSet :: Map.Map CId (STUArray s LIndex LIndex) -> ST s (Map.Map CId [LIndex])
+        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

src/compiler/GF/Compile/PGFtoHaskell.hs

@@ -16,8 +16,8 @@
 
 module GF.Compile.PGFtoHaskell (grammar2haskell) where
 
-import PGF
+import PGF2
-import PGF.Internal
+import PGF2.Internal
 
 import GF.Data.Operations
 import GF.Infra.Option
@@ -242,7 +242,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)
@@ -263,11 +263,11 @@ fInstance gId lexical m (cat,rules) =
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
 hSkeleton gr = 
-  (showCId (abstractName gr),
+  (abstractName gr,
    let fs = 
-         [(showCId c, [(showCId f, map showCId cs) | (f, cs,_) <- fs]) | 
+         [(c, [(f, cs) | (f, cs,_) <- fs]) | 
                                         fs@((_, _,c):_) <- fns]
-   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
+   in fs ++ [(c, []) | c <- cts, notElem c (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
    cts = categories gr

src/compiler/GF/Compile/PGFtoJSON.hs

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

@@ -2,7 +2,7 @@ module GF.Compile.ToAPI
  (stringToAPI,exprToAPI)
   where
 
-import PGF
+import PGF2
 import Data.Maybe
 --import System.IO
 --import Control.Monad
@@ -46,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)
 
         
@@ -68,8 +68,8 @@ mkAPI opt (ty,expr) =
   where
      rephraseSentence ty expr = 
        case unApp expr of 
-         Just (cid,es) -> if isPrefixOf "Use" (showCId cid) then 
+         Just (cid,es) -> if isPrefixOf "Use" cid then 
-                                                             let newCat = drop 3 (showCId cid)
+                                                             let newCat = drop 3 cid
                                                                  afClause = mkAPI True (newCat, es !! 2)
                                                                  afPol = mkAPI True ("Pol",es !! 1)                                         
                                                                  lTense = mkAPI True ("Temp", head es)                                        
@@ -97,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    
@@ -146,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)
+         if cid == "MassNP" then let afs = nounAsCN (head es)
-                                           in AppFunc "mkNP" [afs]
+                                 in AppFunc "mkNP" [afs]
-           else if showCId cid == "DetCN" then let quants = quantAsDet (head es)
+           else if cid == "DetCN" then let quants = quantAsDet (head es)
-                                                   ns     = nounAsCN (head $ tail es)
+                                           ns     = nounAsCN (head $ tail es)
-                                                  in AppFunc "mkNP" (quants ++ [ns])
+                                       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/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

@@ -22,8 +22,7 @@ import GF.Infra.Option
 import GF.Infra.UseIO(MonadIO(..))
 import GF.Grammar.Grammar
 
-import PGF() -- Binary instances
+import PGF2.Internal(Literal(..),Symbol(..))
-import PGF.Internal(Literal(..),Symbol(..))
 
 -- Please change this every time when the GFO format is changed
 gfoVersion = "GF04"

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(LIndex, BindType(..))
+import PGF2.Internal(FId, FunId, SeqId, 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

@@ -24,7 +24,6 @@ import GF.Grammar.Lexer
 import GF.Compile.Update (buildAnyTree)
 import Data.List(intersperse)
 import Data.Char(isAlphaNum)
-import PGF(mkCId)
 
 }
 
@@ -624,7 +623,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 =
@@ -637,7 +636,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

@@ -23,19 +23,16 @@ module GF.Grammar.Printer
            , getAbs
            ) where
 
+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)
 import qualified Data.Map as Map
---import qualified Data.IntMap as IntMap
---import qualified Data.Set as Set
 import qualified Data.Array.IArray as Array
 
 data TermPrintQual 
@@ -362,3 +359,39 @@ 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/Option.hs

@@ -35,7 +35,7 @@ import GF.Infra.Ident
 import GF.Infra.GetOpt
 import GF.Grammar.Predef
 import System.FilePath
-import PGF.Internal(Literal(..))
+import PGF2.Internal(Literal(..))
 
 import GF.Data.Operations(Err,ErrorMonad(..),liftErr)
 
@@ -85,12 +85,9 @@ data Phase = Preproc | Convert | Compile | Link
 data OutputFormat = FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
-                  | FmtJavaScript 
                   | FmtJSON
-                  | FmtPython 
                   | FmtHaskell 
                   | FmtJava
-                  | FmtProlog
                   | FmtBNF
                   | FmtEBNF
                   | FmtRegular
@@ -467,12 +464,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/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,7 +20,7 @@ import GF.Infra.SIO
 import GF.Infra.Option
 import qualified System.Console.Haskeline as Haskeline
 
-import PGF
+import PGF2
 
 import Data.Char
 import Data.List(isPrefixOf)
@@ -274,17 +274,17 @@ importInEnv opts files =
      if flag optRetainResource opts
       then do src <- lift $ importSource opts files
               pgf <- lift . lazySIO $ importPGF pgf0 -- duplicates some work, better to link src
-              modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,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 case pgf1 of
-                  Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf)
+                  Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
                   Nothing  -> done
            else done
          return pgf1
@@ -298,10 +298,10 @@ tryGetLine = do
 prompt env
   | retain env = "> "
   | otherwise  = case multigrammar env of
-                   Just pgf -> showCId (abstractName pgf) ++ "> "
+                   Just pgf -> abstractName pgf ++ "> "
                    Nothing  -> "> "
 
-type CmdEnv = (Grammar,PGFEnv)
+type CmdEnv = (Grammar,Maybe PGF)
 
 data GFEnv = GFEnv {
     startOpts :: Options,
@@ -313,10 +313,10 @@ data GFEnv = GFEnv {
 
 emptyGFEnv opts = GFEnv opts False emptyCmdEnv emptyCommandEnv []
 
-emptyCmdEnv = (emptyGrammar,pgfEnv Nothing)
+emptyCmdEnv = (emptyGrammar,Nothing)
 
 emptyCommandEnv = mkCommandEnv allCommands
-multigrammar = pgf . snd . pgfenv
+multigrammar = snd . pgfenv
 
 allCommands =
   extend pgfCommands (helpCommand allCommands:moreCommands)
@@ -324,7 +324,7 @@ 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
@@ -332,17 +332,13 @@ wordCompletion gfenv (left,right) = do
       -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
     CmplStr (Just (Command _ opts _)) s0
       -> case multigrammar gfenv of
-           Just pgf -> let optLang opts = case valStrOpts "lang" "" opts of
+           Just pgf -> let langs = languages pgf
-                                            ""   -> case languages pgf of
+                           optLang opts = case valStrOpts "lang" "" opts of
-                                                      []       -> Nothing
+                                            ""   -> case Map.minView langs of
-                                                      (lang:_) -> Just lang
+                                                      Nothing        -> Nothing
-                                            lang -> let cla = mkCId lang in
+                                                      Just (concr,_) -> Just concr
-                                                    if elem cla (languages pgf)
+                                            lang -> mplus (Map.lookup lang                       langs)
-                                                      then Just cla
+                                                          (Map.lookup (abstractName pgf ++ lang) langs)
-                                                      else let cla = mkCId (showCId (abstractName pgf) ++ lang)
-                                                           in if elem cla (languages pgf)
-                                                                then Just cla
-                                                                else Nothing
                            optType opts = let readOpt str = case readType str of
                                                               Just ty -> case checkType pgf ty of
                                                                            Left _   -> Nothing
@@ -353,8 +349,8 @@ wordCompletion gfenv (left,right) = do
                            s            = reverse rs
                            prefix       = reverse rprefix
                        in case (optLang opts, optType opts) of
-                            (Just lang,Just cat) -> let (_,_,compls) = complete pgf lang cat s prefix
+                            (Just lang,Just cat) -> let compls = [t | (t,_,_,_) <- complete lang cat s prefix]
-                                                    in ret (length prefix) (map Haskeline.simpleCompletion (Map.keys compls))
+                                                    in ret (length prefix) (map Haskeline.simpleCompletion compls)
                             _                    -> ret 0 []
            Nothing  -> ret 0 []
     CmplOpt (Just (Command n _ _)) pref
@@ -368,7 +364,7 @@ wordCompletion gfenv (left,right) = do
       -> Haskeline.completeFilename (left,right)
     CmplIdent _ pref
       -> case multigrammar gfenv of
-           Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | cid <- functions pgf, let name = showCId cid, isPrefixOf pref name]
+           Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
            Nothing  -> ret (length pref) []
     _ -> ret 0 []
   where

src/compiler/GF/Interactive2.hs

@@ -1,445 +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(..),done)
-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 GF.Text.Coding(decodeUnicode,encodeUnicode)
-
---import GF.Compile.Coding(codeTerm)
-
-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
-                      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 [] = done
-        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
-    [] -> done
-    _ -> do putStrLnE "Can only import one .pgf file"
-  where
-    importPGF file =
-      do gfenv <- get
-         case multigrammar gfenv of
-           Just _ -> putStrLnE "Discarding previous grammar"
-           _ -> done
-         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/Quiz.hs

@@ -18,13 +18,8 @@ module GF.Quiz (
   morphologyList
   ) where
 
-import PGF
+import PGF2
---import PGF.Linearize
 import GF.Data.Operations
---import GF.Infra.UseIO
---import GF.Infra.Option
---import PGF.Probabilistic
-
 import System.Random
 import Data.List (nub)
 
@@ -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
+   homonyms t = 
-   lins = nub . concatMap (map snd) . tabularLinearizes pgf og
+     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

@@ -42,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)
@@ -170,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

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

@@ -8,13 +8,11 @@
 
 module GF.Speech.GSL (gslPrinter) where
 
---import GF.Data.Utilities
 import GF.Grammar.CFG
 import GF.Speech.SRG
 import GF.Speech.RegExp
 import GF.Infra.Option
---import GF.Infra.Ident
+import PGF2
-import PGF
 
 import Data.Char (toUpper,toLower)
 import Data.List (partition)
@@ -23,7 +21,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

@@ -18,7 +18,7 @@ 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
@@ -30,8 +30,8 @@ width :: Int
 width = 75
 
 jsgfPrinter :: Options
-	    -> PGF 
+	        -> PGF 
-            -> CId -> String
+            -> 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/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 PGF2
---import PGF.CId
 
 import Control.Monad
 import qualified Control.Monad.State as STM
 import Data.Char (toUpper)
---import Data.List
 import Data.Maybe
 
 data SLFs = SLFs [(String,SLF)] SLF
@@ -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
+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,
+    SRG { srgName = concreteName cnc,
-	  srgStartCat = cfgStartCat cfg,
+	      srgStartCat = cfgStartCat cfg,
           srgExternalCats = cfgExternalCats cfg,
-          srgLanguage = languageCode pgf cnc,
+          srgLanguage = languageCode cnc,
 	  srgRules = mkRules cfg }
-    where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
+    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

@@ -25,23 +25,21 @@ 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
+	        -> 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,14 +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 PGF2
-import PGF
-
---import Control.Monad (liftM)
 import Data.List (intersperse) -- isPrefixOf, find
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
@@ -21,19 +15,19 @@ import Data.Maybe (fromMaybe)
 --import Debug.Trace
 
 -- | the main function
-grammar2vxml :: PGF -> CId -> String
+grammar2vxml :: PGF -> Concr -> String
-grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
+grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name mb_language start skel qs) ""
     where skel = pgfSkeleton pgf
-          name = showCId cnc
+          name = concreteName cnc
-          qs = catQuestions pgf cnc (map fst skel)
+          qs = catQuestions cnc (map fst skel)
-          language = languageCode pgf cnc
+          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,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty]) | f <- functionsByCat pgf c, Just (hypos,_,_) <- [fmap unType (functionType pgf f)]])
@@ -43,37 +37,23 @@ pgfSkeleton pgf = [(c,[(f,[cat | (_,_,ty) <- hypos, let (_,cat,_) = unType ty])
 -- * Questions to ask 
 --
 
-type CatQuestions = [(CId,String)]
+type CatQuestions = [(Cat,String)]
 
-catQuestions :: PGF -> CId -> [CId] -> CatQuestions
+catQuestions :: Concr -> [Cat] -> CatQuestions
-catQuestions pgf cnc cats = [(c,catQuestion pgf cnc c) | c <- cats]
+catQuestions cnc cats = [(c,catQuestion cnc c) | c <- cats]
 
-catQuestion :: PGF -> CId -> CId -> String
+catQuestion :: Concr -> Cat -> String
-catQuestion pgf cnc cat = showPrintName pgf cnc cat
+catQuestion cnc cat = fromMaybe cat (printName cnc cat)
 
-
+getCatQuestion :: Cat -> CatQuestions -> String
-{-
-lin :: StateGrammar -> String -> Err String
-lin gr fun = do
-             tree <- string2treeErr gr fun
-             let ls = map unt $ linTree2strings noMark g c tree
-             case ls of
-                 [] -> fail $ "No linearization of " ++ fun
-                 l:_ -> return l
-  where c = cncId gr
-        g = stateGrammarST gr
-        unt = formatAsText 
--}
-
-getCatQuestion :: CId -> CatQuestions -> String
 getCatQuestion c qs = 
-    fromMaybe (error "No question for category " ++ 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 
@@ -85,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, 
@@ -103,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 ++ " : (" 
+    comments [fun ++ " : (" 
-              ++ concat (intersperse ", " (map showCId args))
+              ++ concat (intersperse ", " args)
-              ++ ") " ++ showCId cat] ++ ss
+              ++ ") " ++ 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 :: Cat -> String
-catFormId c = showCId c ++ "_cat"
+catFormId c = c ++ "_cat"
 
 
 --

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/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/runtime/c/pgf/pgf.c

@@ -227,7 +227,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) {
@@ -237,7 +237,7 @@ pgf_language_code(PgfConcr* concr)
 	}
 	}
 
-	return "";
+	return NULL;
 }
 
 PGF_API void

src/runtime/haskell-bind/PGF2.hsc

@@ -57,19 +57,24 @@ module PGF2 (-- * PGF
              linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize,
              FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString,
              printName,
+             alignWords, gizaAlignment,
 
-             alignWords,
              -- ** Parsing
              ParseOutput(..), parse, parseWithHeuristics, complete,
+
              -- ** Sentence Lookup
              lookupSentence,
+
              -- ** Generation
-             generateAll,
+             generateAll, generateAllFrom, 
+             generateRandom, generateRandomFrom,
+
              -- ** Morphological Analysis
              MorphoAnalysis, lookupMorpho, lookupCohorts, fullFormLexicon,
              -- ** Visualizations
              GraphvizOptions(..), graphvizDefaults,
              graphvizAbstractTree, graphvizParseTree,
+             Labels, getDepLabels,
              graphvizDependencyTree, conlls2latexDoc, getCncDepLabels,
              graphvizWordAlignment,
 
@@ -77,13 +82,17 @@ module PGF2 (-- * PGF
              PGFError(..),
 
              -- * Grammar specific callbacks
-             LiteralCallback,literalCallbacks
+             LiteralCallback,literalCallbacks,
+
+             -- * Auxiliaries             
+             readProbabilitiesFromFile
             ) where
 
 import Prelude hiding (fromEnum)
 import Control.Exception(Exception,throwIO)
 import Control.Monad(forM_)
 import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO)
+import System.Random
 import Text.PrettyPrint
 import PGF2.Expr
 import PGF2.Type
@@ -171,9 +180,12 @@ languages p = langs p
 concreteName :: Concr -> ConcName
 concreteName c = unsafePerformIO (peekUtf8CString =<< pgf_concrete_name (concr c))
 
-languageCode :: Concr -> String
+languageCode :: Concr -> Maybe String
-languageCode c = unsafePerformIO (peekUtf8CString =<< pgf_language_code (concr c))
+languageCode c = unsafePerformIO $ do
-
+  c_code <- pgf_language_code (concr c)
+  if c_code == nullPtr
+    then return Nothing
+    else fmap Just (peekUtf8CString c_code)
 
 -- | Generates an exhaustive possibly infinite list of
 -- all abstract syntax expressions of the given type. 
@@ -189,6 +201,15 @@ generateAll p (Type ctype _) =
        exprFPl <- newForeignPtr gu_pool_finalizer exprPl
        fromPgfExprEnum enum genFPl (touchPGF p >> touchForeignPtr exprFPl)
 
+generateAllFrom :: PGF -> Expr -> [(Expr,Float)]
+generateAllFrom = error "generateAllFrom is not implemented yet"
+
+generateRandom :: RandomGen gen => gen -> PGF -> Type -> [a]
+generateRandom = error "generateRandom is not implemented yet"
+
+generateRandomFrom :: RandomGen gen => gen -> PGF -> Expr -> [a]
+generateRandomFrom = error "generateRandomFrom is not implemented yet"
+      
 -- | The abstract language name is the name of the top-level
 -- abstract module
 abstractName :: PGF -> AbsName
@@ -448,6 +469,9 @@ graphvizWordAlignment cs opts e =
 
 type Labels = Map.Map Fun [String]
 
+getDepLabels :: String -> Labels
+getDepLabels s = Map.fromList [(f,ls) | f:ls <- map words (lines s)]
+
 -- | Visualize word dependency tree.
 graphvizDependencyTree
   :: String -- ^ Output format: @"latex"@, @"conll"@, @"malt_tab"@, @"malt_input"@ or @"dot"@
@@ -1499,6 +1523,8 @@ alignWords lang e = unsafePerformIO $
       (fids :: [CInt]) <- peekArray (fromIntegral (n_fids :: CInt)) (ptr `plusPtr` (#offset PgfAlignmentPhrase, fids))
       return (phrase, map fromIntegral fids)
 
+gizaAlignment = error "gizaAlignment is not implemented"
+
 printName :: Concr -> Fun -> Maybe String
 printName lang fun =
   unsafePerformIO $
@@ -1729,3 +1755,9 @@ capitalized' not s = Nothing
 tag i
   | i < 0     = char 'r' <> int (negate i)
   | otherwise = char 'n' <> int i
+
+
+readProbabilitiesFromFile :: FilePath -> IO (Map.Map String Double)
+readProbabilitiesFromFile fpath = do
+  s <- readFile fpath
+  return $ Map.fromList [(f,read p) | f:p:_ <- map words (lines s)]

src/runtime/haskell-bind/pgf2.cabal

@@ -18,7 +18,7 @@ library
                        -- backwards compatibility API:
                        PGF, PGF.Internal
   other-modules:       PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI
-  build-depends:       base >=4.3, containers, pretty, array
+  build-depends:       base >=4.3, containers, pretty, array, random
   -- hs-source-dirs:      
   default-language:    Haskell2010
   build-tools:         hsc2hs

src/runtime/python/pypgf.c

@@ -2285,7 +2285,10 @@ Concr_getName(ConcrObject *self, void *closure)
 static PyObject*
 Concr_getLanguageCode(ConcrObject *self, void *closure)
 {
-    return PyString_FromString(pgf_language_code(self->concr));
+	GuString code = pgf_language_code(self->concr);
+	if (code == NULL)
+		Py_RETURN_NONE;
+    return PyString_FromString(code);
 }
 
 static PyObject*

src/server/transfer/Fold.hs

@@ -1,14 +1,15 @@
 module Fold where
-import PGF
+
+import PGF2
 import Data.Map as M (lookup, fromList)
 
 --import Debug.Trace
 
 
-foldable = fromList [(mkCId c, mkCId ("bin_" ++ c)) | c <- ops]
+foldable = fromList [(c, "bin_" ++ c) | c <- ops]
   where ops = words "plus times and or xor cartesian_product intersect union"
 
-fold :: Tree -> Tree
+fold :: Expr -> Expr
 fold t =
   case unApp t of
     Just (i,[x])  ->
@@ -18,9 +19,9 @@ fold t =
     Just (i,xs)   -> mkApp i $ map fold xs
     _             -> t
 
-appFold :: CId -> Tree -> Tree
+appFold :: Fun -> Expr -> Expr
 appFold j t = 
   case unApp t of
     Just (i,[t,ts]) | isPre i "Cons"  -> mkApp j [fold t, appFold j ts]
     Just (i,[t,s])  | isPre i "Base"  -> mkApp j [fold t, fold s]
-  where isPre i s = take 4 (show i) == s
+  where isPre i s = take 4 (show i) == s