"Committed_by_peb"

9 files changed, 134 insertions, 86 deletions

diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index 580bdeb5f..6e6f00176 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/src/GF/Compile/ShellState.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/11 13:53:38 $ 
+-- > CVS $Date: 2005/04/14 11:42:05 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.41 $
+-- > CVS $Revision: 1.42 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -190,7 +190,7 @@ updateShellState opts mcnc sh ((_,sgr,gr),rts) = do
   let pinfosOld = map (CnvOld.pInfo opts cgr) concrs  -- peb 18/6 (OBSOLETE)
 
   let g2s  = Cnv.gfc2simple
-      fin  = Cnv.simple2finite
+      fin  = Cnv.removeSingletons . Cnv.simple2finite
       s2mN = Cnv.simple2mcfg_nondet
       s2mS = Cnv.simple2mcfg_strict
       --                     ____ kan man ha flera '-conversion=X -conversion=Y'?
diff --git a/src/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs
index 5b5c4491e..21b52d2b1 100644
--- a/src/GF/Conversion/GFC.hs
+++ b/src/GF/Conversion/GFC.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/12 10:49:44 $ 
+-- > CVS $Date: 2005/04/14 11:42:05 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- All conversions from GFC 
 -----------------------------------------------------------------------------
@@ -21,6 +21,7 @@ import GF.Conversion.Types (CGrammar, MGrammar, SGrammar)
 
 import qualified GF.Conversion.GFCtoSimple as G2S
 import qualified GF.Conversion.SimpleToFinite as S2Fin
+import qualified GF.Conversion.RemoveSingletons as RemSing
 import qualified GF.Conversion.SimpleToMCFG as S2M
 import qualified GF.Conversion.MCFGtoCFG as M2C
 
@@ -30,6 +31,9 @@ gfc2simple = G2S.convertGrammar
 simple2finite :: SGrammar -> SGrammar
 simple2finite = S2Fin.convertGrammar
 
+removeSingletons :: SGrammar -> SGrammar
+removeSingletons = RemSing.convertGrammar
+
 simple2mcfg_nondet :: SGrammar -> MGrammar
 simple2mcfg_nondet = S2M.convertGrammarNondet
 
diff --git a/src/GF/Conversion/GFCtoSimple.hs b/src/GF/Conversion/GFCtoSimple.hs
index 5e4313b1b..a93652866 100644
--- a/src/GF/Conversion/GFCtoSimple.hs
+++ b/src/GF/Conversion/GFCtoSimple.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/12 10:49:44 $ 
+-- > CVS $Date: 2005/04/14 11:42:05 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- Converting GFC to SimpleGFC
 --
@@ -54,23 +54,30 @@ convertAbsFun gram fun typing = Rule abs cnc
 
 convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name
 convertAbstract env fun (A.EProd x a b) 
-    = convertAbstract ((x' ::: convertType [] a) : env) fun b
+    = convertAbstract (convertType x' [] a : env) fun b
     where x' = if x==I.identC "h_" then anyVar else x
 convertAbstract env fun a 
-    = Abs (anyVar ::: convertType [] a) (reverse env) name
+    = Abs (convertType anyVar [] a) (reverse env) name
     where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ]
 
-convertType :: [Atom] -> A.Exp -> SType
-convertType args (A.EApp a (A.EAtom at)) = convertType (convertAtom at : args) a
-convertType args (A.EAtom at) = convertCat at :@ args
+convertType :: Var -> [TTerm] -> A.Exp -> SDecl
+convertType x args (A.EApp a b) = convertType x (convertExp [] b : args) a
+convertType x args (A.EAtom at) = Decl x (convertCat at) args
+convertType x args exp = error $ "convertType: " ++ prt exp
 
-convertAtom :: A.Atom -> Atom
-convertAtom (A.AC con) = ACon con
-convertAtom (A.AV var) = AVar var
+convertExp :: [TTerm] -> A.Exp -> TTerm
+convertExp args (A.EAtom at) = convertAtom args at
+convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
+convertExp args exp = error $ "convertExp: " ++ prt exp
+
+convertAtom :: [TTerm] -> A.Atom -> TTerm
+convertAtom args (A.AC con) = con :@ reverse args
+convertAtom []   (A.AV var) = TVar var
+convertAtom args atom = error $ "convertAtom: " ++ prt args ++ " " ++ prt atom
 
 convertCat :: A.Atom -> SCat
 convertCat (A.AC (A.CIQ _ cat)) = cat
-convertCat at = error $ "convertCat: " ++ show at
+convertCat atom = error $ "convertCat: " ++ show atom
 
 ----------------------------------------------------------------------
 -- concrete definitions
@@ -101,10 +108,10 @@ convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term
 					A.Cas pats term <- tbl, pat <- pats ]
 convertTerm gram (A.S term sel) = convertTerm gram term +! convertTerm gram sel
 convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
-convertTerm gram (A.FV terms) = Variants (map (convertTerm gram) terms)
+convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms)
 -- 'pre' tokens are converted to variants (over-generating):
 convertTerm gram (A.K (A.KP [s] vs))
-    = Variants $ Token s : [ Token v | A.Var [v] _ <- vs ]
+    = variants $ Token s : [ Token v | A.Var [v] _ <- vs ]
 convertTerm gram (A.K (A.KP _ _)) = error "convertTerm: don't know how to handle string lists in 'pre' tokens"
 convertTerm gram (A.K (A.KS tok)) = Token tok
 convertTerm gram (A.E) = Empty
diff --git a/src/GF/Conversion/SimpleToFinite.hs b/src/GF/Conversion/SimpleToFinite.hs
index cc180a7e1..f462ddf01 100644
--- a/src/GF/Conversion/SimpleToFinite.hs
+++ b/src/GF/Conversion/SimpleToFinite.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/12 10:49:44 $ 
+-- > CVS $Date: 2005/04/14 11:42:05 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- Calculating the finiteness of each type in a grammar
 -----------------------------------------------------------------------------
@@ -43,35 +43,35 @@ convertRule split (Rule abs cnc)
 
 convertAbstract :: Splitable -> Abstract SDecl Name
 		-> CnvMonad (Abstract SDecl Name)
-convertAbstract split (Abs (_ ::: typ) decls name)
+convertAbstract split (Abs decl decls name)
     = case splitableFun split (name2fun name) of
-        Just newCat -> return $ Abs (anyVar ::: (newCat :@ [])) decls name
-	Nothing -> expandTyping split name [] typ decls []
+        Just newCat -> return $ Abs (Decl anyVar newCat []) decls name
+	Nothing -> expandTyping split name [] decl decls []
 
 
-expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SType -> [SDecl] -> [SDecl] 
+expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl] 
 	     -> CnvMonad (Abstract SDecl Name)
-expandTyping split fun env (cat :@ atoms) [] decls 
+expandTyping split fun env (Decl x cat args) [] decls 
     = return $ Abs decl (reverse decls) fun
-    where decl = anyVar ::: substAtoms split env cat atoms []
-expandTyping split fun env typ ((x ::: (xcat :@ xatoms)) : declsToDo) declsDone
+    where decl = substArgs split x env cat args []
+expandTyping split fun env typ (Decl x xcat xargs : declsToDo) declsDone
     = do (xcat', env') <- calcNewEnv
-         let decl = x ::: substAtoms split env xcat' xatoms []
+         let decl = substArgs split x env xcat' xargs []
 	 expandTyping split fun env' typ declsToDo (decl : declsDone)
     where calcNewEnv = case splitableCat split xcat of
 		         Just newCats -> do newCat <- member newCats
 					    return (newCat, (x,newCat) : env)
 			 Nothing -> return (xcat, env)
 
-substAtoms :: Splitable -> [(Var, SCat)] -> SCat -> [Atom] -> [Atom] -> SType
-substAtoms split env cat [] atoms = cat :@ reverse atoms
-substAtoms split env cat (atom:atomsToDo) atomsDone
-    = case atomLookup split env atom of
-        Just newCat -> substAtoms split env (mergeArg cat newCat) atomsToDo atomsDone
-	Nothing -> substAtoms split env cat atomsToDo (atom : atomsDone)
+substArgs :: Splitable -> Var -> [(Var, SCat)] -> SCat -> [TTerm] -> [TTerm] -> SDecl
+substArgs split x env cat [] args = Decl x cat (reverse args)
+substArgs split x env cat (arg:argsToDo) argsDone
+    = case argLookup split env arg of
+        Just newCat -> substArgs split x env (mergeArg cat newCat) argsToDo argsDone
+	Nothing     -> substArgs split x env cat argsToDo (arg : argsDone)
 
-atomLookup split env (AVar x) = lookup x env 
-atomLookup split env (ACon con) = splitableFun split (constr2fun con)
+argLookup split env (TVar x)   = lookup x env 
+argLookup split env (con :@ _) = splitableFun split (constr2fun con)
       
 
 ----------------------------------------------------------------------
@@ -96,7 +96,7 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
 
           -- cat-fun pairs that are splitable
 	  splitableCatFuns = [ (cat, name2fun name) |
-			       Rule (Abs (_ ::: (cat :@ [])) [] name) _ <- rules,
+			       Rule (Abs (Decl _ cat []) [] name) _ <- rules,
 			       splitableCats ?= cat ]
 
           -- all cats that are splitable
@@ -105,20 +105,20 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
 			  (nondepCats <**> depCats) <\\> resultCats
 
           -- all result cats for some pure function
-	  resultCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ _)) decls _) _ <- rules,
+	  resultCats = nubsort [ cat | Rule (Abs (Decl _ cat _) decls _) _ <- rules,
 				 not (null decls) ]
 
           -- all cats in constants without dependencies
-          nondepCats = nubsort [ cat | Rule (Abs (_ ::: (cat :@ [])) [] _) _ <- rules ]
+          nondepCats = nubsort [ cat | Rule (Abs (Decl _ cat []) [] _) _ <- rules ]
 
           -- all cats occurring as some dependency of another cat
 	  depCats = nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
 			      cat <- varCats [] (decls ++ [decl]) ]
 
 	  varCats _ [] = []
-	  varCats env ((x ::: (xcat :@ atoms)) : decls)
+	  varCats env (Decl x xcat args : decls)
 	      = varCats ((x,xcat) : env) decls ++
-		[ cat | AVar y <- atoms, cat <- lookupList y env ]
+		[ cat | arg <- args, y <- varsInTTerm arg, cat <- lookupList y env ]
 
 
 ----------------------------------------------------------------------
diff --git a/src/GF/Conversion/Types.hs b/src/GF/Conversion/Types.hs
index 672a57012..d193f6d67 100644
--- a/src/GF/Conversion/Types.hs
+++ b/src/GF/Conversion/Types.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/12 10:49:44 $ 
+-- > CVS $Date: 2005/04/14 11:42:05 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- All possible instantiations of different grammar formats used in conversion from GFC
 -----------------------------------------------------------------------------
@@ -49,20 +49,31 @@ name2fun (Name fun _) = fun
 data Profile a = Unify [Int] -- ^ The Int's are the argument positions.
 			     -- 'Unify []' will become a metavariable,
 			     -- 'Unify [a,b]' means that the arguments are equal,
-	       | Epsilon a
+	       | Constant a
 		 deriving (Eq, Ord, Show)
 
+instance Functor Profile where
+    fmap f (Constant a) = Constant (f a)
+    fmap f (Unify xs)   = Unify xs
+
+-- | a function name where the profile does not contain
+constantNameToForest :: Name -> SyntaxForest Fun
+constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile] 
+    where unConstant (Constant a) = a
+	  unConstant (Unify [])   = FMeta
+	  unConstant _ = error $ "constantNameToForest: the profile should not contain arguments: " ++ prt name
+
 -- | profile application; we need some way of unifying a list of arguments
 applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a]
 applyProfile unify profile args = map apply profile
     where apply (Unify xs)  = unify $ map (args !!) xs
-	  apply (Epsilon a) = a
+	  apply (Constant a) = a
 
 -- | monadic profile application
 applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a]
 applyProfileM unify profile args = mapM apply profile
     where apply (Unify xs)  = unify $ map (args !!) xs
-	  apply (Epsilon a) = return a
+	  apply (Constant a) = return a
 
 -- | profile composition: 
 -- 
@@ -76,13 +87,13 @@ applyProfileM unify profile args = mapM apply profile
 -- >      ==
 -- >   p (q arg)
 --
--- Note that composing an 'Epsilon' with two or more arguments returns an error
+-- Note that composing an 'Constant' with two or more arguments returns an error
 -- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need.
 composeProfiles :: [Profile a] -> [Profile a] -> [Profile a]
 composeProfiles ps qs = map compose ps
     where compose (Unify [x]) = qs !! x
 	  compose (Unify xs)  = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ]
-	  compose epsilon     = epsilon
+	  compose constant    = constant
 
 
 
@@ -103,7 +114,6 @@ type SPath    = Path    SCat Token
 type STerm    = Term    SCat Token
 type SLinType = LinType SCat Token
 type SDecl    = Decl    SCat
-type SType    = Type    SCat
 
 ----------------------------------------------------------------------
 -- * MCFG
@@ -159,6 +169,6 @@ instance Print Name where
 instance Print a => Print (Profile a) where
     prt (Unify [])   = "?"
     prt (Unify args) = prtSep "=" args
-    prt (Epsilon a)  = prt a
+    prt (Constant a) = prt a
 
 
diff --git a/src/GF/Formalism/SimpleGFC.hs b/src/GF/Formalism/SimpleGFC.hs
index 4091b9fdd..dfddc212d 100644
--- a/src/GF/Formalism/SimpleGFC.hs
+++ b/src/GF/Formalism/SimpleGFC.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/12 10:49:45 $ 
+-- > CVS $Date: 2005/04/14 11:42:05 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- Simplistic GFC format
 -----------------------------------------------------------------------------
@@ -39,16 +39,29 @@ type SimpleRule    c n t = Rule     (Decl c) n (LinType c t) (Maybe (Term c t))
 
 -- ** dependent type declarations
 
-data Decl c = Var ::: Type c
-		   deriving (Eq, Ord, Show)
-data Type c = c :@ [Atom]
-		   deriving (Eq, Ord, Show)
-data Atom   = ACon Constr
-	    | AVar Var
+-- | 'Decl x c ts' == x is of type (c applied to ts)
+data Decl c = Decl Var c [TTerm]
+	      deriving (Eq, Ord, Show)
+data TTerm  = Constr :@ [TTerm]
+	    | TVar Var
 	      deriving (Eq, Ord, Show)
 
 decl2cat :: Decl c -> c
-decl2cat (_ ::: (cat :@ _)) = cat
+decl2cat (Decl _ cat _) = cat
+
+varsInTTerm :: TTerm -> [Var]
+varsInTTerm tterm = vars tterm []
+    where vars (TVar x)  = (x:)
+	  vars (_ :@ ts) = foldr (.) id $ map vars ts
+
+tterm2term :: TTerm -> Term c t
+tterm2term (con :@ terms) = con :^ map tterm2term terms
+tterm2term (TVar x) = Var x
+
+term2tterm :: Term c t -> TTerm
+term2tterm (con :^ terms) = con :@ map term2tterm terms
+term2tterm (Var x) = TVar x
+term2tterm term = error $ "term2tterm: illegal term"
 
 -- ** linearization types and terms
 
@@ -172,38 +185,42 @@ lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt |
 ----------------------------------------------------------------------
 
 instance Print c => Print (Decl c) where
-    prt (var ::: typ) 
-	| var == anyVar = prt typ
-	| otherwise     = prt var ++ ":" ++ prt typ 
-
-instance Print c => Print (Type c) where
-    prt (cat :@ ats) = prt cat ++ prtList ats
-
-instance Print Atom where
-    prt (ACon con) = prt con
-    prt (AVar var) = "?" ++ prt var
+    prt (Decl var cat args) 
+	| null args = prVar ++ prt cat
+	| otherwise = "(" ++ prVar ++ prt cat ++ prtBefore " " args ++ ")"
+	where prVar | var == anyVar = ""
+		    | otherwise     = "?" ++ prt var ++ ":"
+
+instance Print TTerm where
+    prt (con :@ args)
+	| null args = prt con
+	| otherwise = "(" ++ prt con ++ prtBefore " " args ++ ")"
+    prt (TVar var)  = "?" ++ prt var
 
 instance (Print c, Print t) => Print (LinType c t) where
-    prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
+    prt (RecT rec) = "{" ++ prtInterior ":" rec ++ "}"
     prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")"
     prt (ConT t ts) = prt t ++ "[" ++ prtSep "|" ts ++ "]"
     prt (StrT) = "Str"
 
 instance (Print c, Print t) => Print (Term c t) where
-    prt (Arg n c p) = prt c ++ "@" ++ prt n ++ "(" ++ prt p ++ ")"
+    prt (Arg n c p) = prt c ++ prt n ++ prt p
     prt (c :^ [])  = prt c 
-    prt (c :^ ts)  = prt c ++ prtList ts
-    prt (Rec rec)   = "{" ++ concat [ prt l ++ "=" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
-    prt (Tbl tbl)   = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ "; " | (p,t) <- tbl ] ++ "]"
+    prt (c :^ ts)  = "(" ++ prt c ++ prtBefore " " ts ++ ")"
+    prt (Rec rec)   = "{" ++ prtInterior "=" rec ++ "}"
+    prt (Tbl tbl)   = "[" ++ prtInterior "=>" tbl ++ "]"
     prt (Variants ts)  = "{| " ++ prtSep " | " ts ++ " |}"
     prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
-    prt (Token t)   = prt t
+    prt (Token t)   = "'" ++ prt t ++ "'"
     prt (Empty)     = "[]"
     prt (Wildcard)  = "_"
     prt (term :. lbl) = prt term ++ "." ++ prt lbl
     prt (term :! sel) = prt term ++ "!" ++ prt sel
     prt (Var var) = "?" ++ prt var
 
+prtInterior sep xys = if null str then str else init (init str) 
+    where str = concat [ prt x ++ sep  ++ prt y ++ "; " | (x,y) <- xys ]
+
 instance (Print c, Print t) => Print (Path c t) where
     prt (Path path) = concatMap prtEither (reverse path)
 	where prtEither (Left  lbl)  = "." ++ prt lbl
diff --git a/src/GF/Formalism/Utilities.hs b/src/GF/Formalism/Utilities.hs
index 166534bc4..a03464e04 100644
--- a/src/GF/Formalism/Utilities.hs
+++ b/src/GF/Formalism/Utilities.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/11 13:52:50 $ 
+-- > CVS $Date: 2005/04/14 11:42:05 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Basic type declarations and functions for grammar formalisms
 -----------------------------------------------------------------------------
@@ -259,12 +259,18 @@ instance (Print s) => Print (Edge s) where
     prtList = prtSep ""
 
 instance (Print s) => Print (SyntaxTree s) where
-    prt (TNode s trees) = prt s ++ "^{" ++ prtSep " " trees ++ "}"
+    prt (TNode s trees)
+	| null trees = prt s
+	| otherwise  = "(" ++ prt s ++ prtBefore " " trees ++ ")"
     prt (TMeta) = "?"
     prtList = prtAfter "\n"
 
 instance (Print s) => Print (SyntaxForest s) where
-    prt (FNode s forests) = prt s ++ "^{" ++ prtSep " | " (map (prtSep " ") forests) ++ "}"
+    prt (FNode s []) = "(" ++ prt s ++ " - ERROR: null forests)"
+    prt (FNode s [[]]) = prt s
+    prt (FNode s [forests]) = "(" ++ prt s ++ prtBefore " " forests ++ ")"
+    prt (FNode s children) = "{" ++ prtSep " | " [ prt s ++ prtBefore " " forests | 
+						   forests <- children ] ++ "}"
     prt (FMeta) = "?"
     prtList = prtAfter "\n"
 
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 519413af5..441d6bd14 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/12 10:49:45 $ 
+-- > CVS $Date: 2005/04/14 11:42:06 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.52 $
+-- > CVS $Revision: 1.53 $
 --
 -- A database for customizable GF shell commands. 
 --
@@ -264,6 +264,9 @@ customGrammarPrinter =
 -- obsolete, or only for testing:
   ,(strCI "simple",   Prt2.prt . Cnv.gfc2simple . stateGrammarLang)
   ,(strCI "finite",   Prt2.prt . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
+  ,(strCI "single",   Prt2.prt . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
+  ,(strCI "sg-sg",    Prt2.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
+  ,(strCI "sg-sg-sg", Prt2.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
   ,(strCI "mcfg-old", Prt.prt . CnvOld.mcfg . statePInfoOld)
   ,(strCI "cfg-old",  Prt.prt . CnvOld.cfg . statePInfoOld)
   ] 
diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs
index ae890b757..a50de2db7 100644
--- a/src/GF/UseGrammar/Parsing.hs
+++ b/src/GF/UseGrammar/Parsing.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/11 13:53:39 $ 
+-- > CVS $Date: 2005/04/14 11:42:06 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.16 $
+-- > CVS $Revision: 1.17 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -57,12 +57,12 @@ parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree]
 parseStringC opts0 sg cat s
 
 ---- to test peb's new parser 6/10/2003
----- (to be obsoleted by "newer" below
+---- (to be obsoleted by "newer" below)
  | oElem newParser opts0 = do  
   let pm = maybe "" id $ getOptVal opts0 useParser -- -parser=pm
       ct = cfCat2Cat cat
   ts <- checkErr $ NewOld.newParser pm sg ct s
-  mapM (checkErr . annotate (stateGrammarST sg)) ts
+  mapM (checkErr . annotate (stateGrammarST sg) . refreshMetas []) ts
 
 ---- to test peb's newer parser 7/4-05 
  | oElem newerParser opts0 = do  
@@ -70,7 +70,8 @@ parseStringC opts0 sg cat s
       pm   = maybe "" id $ getOptVal opts0 useParser -- -parser=pm
       tok  = customOrDefault opts useTokenizer customTokenizer sg
   ts <- return $ New.parse pm (pInfo sg) (absId sg) cat (tok s)
-  mapM (checkErr . annotate (stateGrammarST sg)) ts
+  ts' <- mapM (checkErr . annotate (stateGrammarST sg) . refreshMetas []) ts
+  return $ optIntOrAll opts flagNumber ts'
 
  | otherwise = do
   let opts = unionOptions opts0 $ stateOptions sg