"Committed_by_peb"

4 files changed, 68 insertions, 47 deletions

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