"Committed_by_peb"

5 files changed, 89 insertions, 63 deletions

diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index a8afb8a01..a484b50e8 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/21 16:46:01 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.45 $
+-- > CVS $Date: 2005/09/01 09:53:18 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.46 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -189,7 +189,7 @@ updateShellState opts mcnc sh ((_,sgr,gr),rts) = do
 
   let pinfosOld = map (CnvOld.pInfo opts cgr) concrs  -- peb 18/6 (OBSOLETE)
 
-  let fromGFC       = Cnv.gfc2mcfg2cfg opts
+  let fromGFC       = snd . snd . Cnv.convertGFC opts
       (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs 
       pInfos        = zipWith Prs.buildPInfo mcfgs cfgs
 
diff --git a/src/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs
index c0d1b68b2..0975d552a 100644
--- a/src/GF/Conversion/GFC.hs
+++ b/src/GF/Conversion/GFC.hs
@@ -4,16 +4,16 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/08/11 14:11:46 $ 
+-- > CVS $Date: 2005/09/01 09:53:18 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.13 $
+-- > CVS $Revision: 1.14 $
 --
 -- All conversions from GFC 
 -----------------------------------------------------------------------------
 
 module GF.Conversion.GFC
     (module GF.Conversion.GFC,
-     SGrammar, MGrammar, CGrammar) where
+     SGrammar, EGrammar, MGrammar, CGrammar) where
 
 import GF.Infra.Option
 import GF.Canon.GFC (CanonGrammar)
@@ -40,30 +40,39 @@ import GF.System.Tracing
 ----------------------------------------------------------------------
 -- * GFC -> MCFG & CFG, using options to decide which conversion is used
 
-gfc2mcfg2cfg :: Options -> (CanonGrammar, Ident) -> (MGrammar, CGrammar)
-gfc2mcfg2cfg opts = \g -> let e = g2e g in trace2 "Options" (show opts) (e2m e, e2c e)
-    where e2c = mcfg2cfg
+convertGFC :: Options -> (CanonGrammar, Ident) -> (SGrammar, (EGrammar, (MGrammar, CGrammar)))
+convertGFC opts = \g -> let s = g2s g
+                            e = s2e s 
+                        in trace2 "Options" (show opts) (s, (e, (e2m e, e2c e)))
+    where e2c = M2C.convertGrammar
 	  e2m = case getOptVal opts firstCat of
-		  Just cat -> flip removeErasing [identC cat]
-		  Nothing  -> flip removeErasing []
-	  g2e = case getOptVal opts gfcConversion of
-		  Just "strict"            -> simple2mcfg_strict .                                    gfc2simple
-		  Just "finite"            -> simple2mcfg_nondet .                    simple2finite . gfc2simple
-		  Just "singletons"        -> simple2mcfg_nondet . removeSingletons .                 gfc2simple
-		  Just "epsilon"           -> removeEpsilon      . simple2mcfg_nondet .               gfc2simple
-		  Just "finite-singletons" -> simple2mcfg_nondet . removeSingletons . simple2finite . gfc2simple
-		  Just "finite-strict"     -> simple2mcfg_strict .                    simple2finite . gfc2simple
-		  _                        -> simple2mcfg_nondet .                                    gfc2simple
+		  Just cat -> flip RemEra.convertGrammar [identC cat]
+		  Nothing  -> flip RemEra.convertGrammar []
+	  s2e = case getOptVal opts gfcConversion of
+		  Just "strict"            -> S2M.convertGrammarStrict
+		  Just "finite-strict"     -> S2M.convertGrammarStrict
+		  Just "epsilon"           -> RemEps.convertGrammar . S2M.convertGrammarNondet
+		  _                        -> S2M.convertGrammarNondet
+	  g2s = case getOptVal opts gfcConversion of
+		  Just "finite"            ->                          S2Fin.convertGrammar . G2S.convertGrammar
+		  Just "singletons"        -> RemSing.convertGrammar .                        G2S.convertGrammar
+		  Just "finite-singletons" -> RemSing.convertGrammar . S2Fin.convertGrammar . G2S.convertGrammar
+		  Just "finite-strict"     ->                          S2Fin.convertGrammar . G2S.convertGrammar
+		  _                        ->                                                 G2S.convertGrammar
+
+gfc2simple :: Options -> (CanonGrammar, Ident) -> SGrammar
+gfc2simple opts = fst . convertGFC opts 
 
 gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar
-gfc2mcfg opts = fst . gfc2mcfg2cfg opts
+gfc2mcfg opts = fst . snd . snd . convertGFC opts
 
 gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar
-gfc2cfg opts = snd . gfc2mcfg2cfg opts
+gfc2cfg opts = snd . snd . snd . convertGFC opts
 
 ----------------------------------------------------------------------
 -- * single step conversions
 
+{-
 gfc2simple :: (CanonGrammar, Ident) -> SGrammar
 gfc2simple = G2S.convertGrammar
 
@@ -74,7 +83,7 @@ removeSingletons :: SGrammar -> SGrammar
 removeSingletons = RemSing.convertGrammar
 
 simple2mcfg_nondet :: SGrammar -> EGrammar
-simple2mcfg_nondet = S2M.convertGrammarNondet
+simple2mcfg_nondet = 
 
 simple2mcfg_strict :: SGrammar -> EGrammar
 simple2mcfg_strict = S2M.convertGrammarStrict
@@ -87,13 +96,14 @@ removeErasing = RemEra.convertGrammar
 
 removeEpsilon :: EGrammar -> EGrammar
 removeEpsilon = RemEps.convertGrammar 
+-}
 
 ----------------------------------------------------------------------
 -- * converting to some obscure formats
 
 gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun]
 gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) |
-		    Rule (Abs decl decls name) _ <- gfc2simple gr ]
+		    Rule (Abs decl decls name) _ <- G2S.convertGrammar gr ]
 
 abstract2skvatt :: [Abstract SCat Fun] -> String
 abstract2skvatt gr = skvatt_hdr ++ concatMap abs2pl gr
diff --git a/src/GF/Conversion/Prolog.hs b/src/GF/Conversion/Prolog.hs
index 281960048..eecc4ca55 100644
--- a/src/GF/Conversion/Prolog.hs
+++ b/src/GF/Conversion/Prolog.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/08/18 13:18:10 $ 
+-- > CVS $Date: 2005/09/01 09:53:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- Converting/Printing different grammar formalisms in Prolog-readable format
 -----------------------------------------------------------------------------
@@ -34,12 +34,13 @@ import GF.Canon.GFC (CanonGrammar)
 import GF.Infra.Ident (Ident(..))
 
 import Data.Maybe (maybeToList, listToMaybe)
+import Data.Char (isLower, isAlphaNum)
 
 ----------------------------------------------------------------------
 -- | printing multiple languages at the same time
 
 prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String
-prtSMulti = prtMulti prtSHeader prtSRule (const Cnv.gfc2simple)
+prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple
 prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg
 prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg
 
@@ -78,9 +79,9 @@ prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm))
     = (if null lang then "" else prtQ lang ++ " : ") ++ 
       prtFunctor "gfcrule" [plfun, plcat, plcats, plcnc] ++ "."
     where plfun  = prtQ fun
-          plcat  = prtQ cat
-          plcats = prtFunctor "c" (map prtQ cats) 
-	  plcnc  = "\n\t" ++ prtSTerm (maybe (Variants []) id mterm)
+          plcat  = prtSCat cat
+          plcats = prtFunctor "c" (map prtSCat cats) 
+	  plcnc  = "\n\t" ++ prtSTerm (maybe Empty id mterm)
 
 prtSTerm (Arg n c p)    = prtFunctor "arg" [prtQ c, prtSPath p, prt (n+1)]
 -- prtSTerm (c :^ [])   = prtQ c
@@ -98,6 +99,13 @@ prtSTerm (term :! sel)  = prtOper "/" (prtSTerm term) (prtSTerm sel)
 
 prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path)
 
+prtSCat (Decl var cat args)     = prVar ++ prtFunctor (prtQ cat) (map prtSTTerm args)
+    where prVar | var == anyVar = ""
+                | otherwise     = "_" ++ prt var ++ ":"
+
+prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args)
+prtSTTerm (TVar var)    = "_" ++ prt var
+
 ----------------------------------------------------------------------
 -- | MCFG to Prolog
 prtMGrammar :: MGrammar -> String
@@ -108,14 +116,13 @@ prtMHeader = prtLine ++++
              "%% Multiple context-free grammar in Prolog-readable format" ++++
              "%% Autogenerated from the Grammatical Framework" +++++
              "%% The following predicate is defined:" ++++
-             "%% \t mcfgrule(Fun, p(Profile,...), Cat, c(Cat,...), [Lbl=Symbols,...])" 
+             "%% \t mcfgrule(Fun(Profile,...), Cat, c(Cat,...), [Lbl=Symbols,...])" 
 
 prtMRule :: String -> MRule -> String
-prtMRule lang (Rule (Abs cat cats (Name fun profiles)) (Cnc _lcat _lcats lins)) 
+prtMRule lang (Rule (Abs cat cats name) (Cnc _lcat _lcats lins)) 
     = (if null lang then "" else prtQ lang ++ " : ") ++ 
-      prtFunctor "mcfgrule" [plfun, plprof, plcat, plcats, pllins] ++ "."
-    where plfun  = prtQ fun
-          plprof = prtFunctor "p" (map prtProfile profiles) 
+      prtFunctor "mcfgrule" [plname, plcat, plcats, pllins] ++ "."
+    where plname = prtName name
           plcat  = prtQ cat
           plcats = prtFunctor "c" (map prtQ cats) 
           pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]"
@@ -135,14 +142,13 @@ prtCHeader = prtLine ++++
              "%% Context-free grammar in Prolog-readable format" ++++
              "%% Autogenerated from the Grammatical Framework" +++++
              "%% The following predicate is defined:" ++++
-             "%% \t cfgrule(Fun, p(Profile,...), Cat, [Symbol,...])"
+             "%% \t cfgrule(Fun(Profile,...), Cat, [Symbol,...])"
 
 prtCRule :: String -> CRule -> String
-prtCRule lang (CFRule cat syms (Name fun profiles)) 
+prtCRule lang (CFRule cat syms name)
     = (if null lang then "" else prtQ lang ++ " : ") ++ 
-      prtFunctor "cfgrule" [plfun, plprof, plcat, plsyms] ++ "."
-    where plfun  = prtQ fun
-          plprof = prtFunctor "p" (map prtProfile profiles) 
+      prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "."
+    where plname = prtName name
           plcat  = prtQ cat
           plsyms = prtPList (map prtCSymbol syms) 
 
@@ -156,16 +162,26 @@ prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")"
 prtPList     xs = "[" ++ prtSep ", " xs ++ "]"
 prtOper   f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")"
 
-prtProfile (Unify [arg]) = show (succ arg)
-prtProfile (Unify args)  = show (map succ args)
+prtName (Name fun profiles)
+    | and (zipWith (==) profiles (map (Unify . return) [0..])) = prtQ fun
+    | otherwise = prtFunctor (prtQ fun) (map prtProfile profiles) 
+
+prtProfile (Unify []) = " ? "
+prtProfile (Unify args) = foldr1 (prtOper "=") (map (show . succ) args)
 prtProfile (Constant forest) = prtForest forest
 
-prtForest (FMeta) = "fmeta"
-prtForest (FNode fun fss) = prtFunctor "fnode" [prtQ fun, prtFss fss]
-    where prtFss fss = prtPList (map prtFs fss) 
-	  prtFs  fs  = prtPList (map prtForest fs) 
+prtForest (FMeta) = " ? "
+prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (prtPList (map prtForest fs))
+prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (prtPList (map prtForest fs)) |
+                                       fs <- fss ]
+
+prtQ atom = prtQStr (prt atom)
 
-prtQ x = "'" ++ concatMap esc (prt x) ++ "'"
+prtQStr atom@(x:xs) 
+    | isLower x && all isAlphaNumUnder xs = atom
+    where isAlphaNumUnder '_' = True
+          isAlphaNumUnder x = isAlphaNum x
+prtQStr atom =  "'" ++ concatMap esc (prt atom) ++ "'"
     where esc '\'' = "\\'"
           esc '\n' = "\\n"
           esc '\t' = "\\t"
diff --git a/src/GF/Conversion/SimpleToFinite.hs b/src/GF/Conversion/SimpleToFinite.hs
index adc8afc78..b875a698e 100644
--- a/src/GF/Conversion/SimpleToFinite.hs
+++ b/src/GF/Conversion/SimpleToFinite.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/13 12:40:19 $ 
+-- > CVS $Date: 2005/09/01 09:53:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.6 $
+-- > CVS $Revision: 1.7 $
 --
 -- Calculating the finiteness of each type in a grammar
 -----------------------------------------------------------------------------
@@ -56,13 +56,13 @@ expandTyping split fun env (Decl x cat args) [] decls
     = return $ Abs decl (reverse decls) fun
     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 = substArgs split x env xcat' xargs []
+    = do (x', xcat', env') <- calcNewEnv
+         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)
+					    return (anyVar, newCat, (x,newCat) : env)
+			 Nothing -> return (x, xcat, env)
 
 substArgs :: Splitable -> Var -> [(Var, SCat)] -> SCat -> [TTerm] -> [TTerm] -> SDecl
 substArgs split x env cat [] args = Decl x cat (reverse args)
@@ -96,7 +96,8 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
 			     [ (fun, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ]
 
           -- cat-fun pairs that are splitable
-	  splitableCatFuns = [ (cat, name2fun name) |
+	  splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $
+                             [ (cat, name2fun name) |
 			       Rule (Abs (Decl _ cat []) [] name) _ <- rules,
 			       splitableCats ?= cat ]
 
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 340db4187..2e54bcb18 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/08/18 13:18:10 $ 
+-- > CVS $Date: 2005/09/01 09:53:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.68 $
+-- > CVS $Revision: 1.69 $
 --
 -- A database for customizable GF shell commands. 
 --
@@ -264,24 +264,23 @@ customGrammarPrinter =
   ,(strCI "pinfo",    Prt.prt . statePInfo)
   ,(strCI "abstract", Prt.prtAfter "\n" . Cnv.gfc2abstract . stateGrammarLang)
 
-  ,(strCI "gfc-haskell",  CnvHaskell.prtSGrammar . Cnv.gfc2simple . stateGrammarLang)
+  ,(strCI "gfc-haskell",  CnvHaskell.prtSGrammar . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
   ,(strCI "mcfg-haskell", CnvHaskell.prtMGrammar . stateMCFG)
   ,(strCI "cfg-haskell",  CnvHaskell.prtCGrammar . stateCFG)
-  ,(strCI "gfc-prolog",   CnvProlog.prtSGrammar . Cnv.gfc2simple . stateGrammarLang)
+  ,(strCI "gfc-prolog",   CnvProlog.prtSGrammar . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
   ,(strCI "mcfg-prolog",  CnvProlog.prtMGrammar . stateMCFG)
   ,(strCI "cfg-prolog",   CnvProlog.prtCGrammar . stateCFG)
 
 -- obsolete, or only for testing:
   ,(strCI "abs-skvatt", Cnv.abstract2skvatt . Cnv.gfc2abstract . stateGrammarLang)
   ,(strCI "cfg-skvatt", Cnv.cfg2skvatt . stateCFG)
-  ,(strCI "simple",   Prt.prt . Cnv.gfc2simple . stateGrammarLang)
-  ,(strCI "mcfg-erasing", Prt.prt . Cnv.simple2mcfg_nondet . Cnv.gfc2simple . stateGrammarLang)
-  ,(strCI "finite",   Prt.prt . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
-  ,(strCI "single",   Prt.prt . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
-  ,(strCI "sg-sg",    Prt.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
+  ,(strCI "simple",   Prt.prt . uncurry Cnv.gfc2simple . stateGrammarLangOpts)
+  ,(strCI "mcfg-erasing", Prt.prt . fst . snd . uncurry Cnv.convertGFC . stateGrammarLangOpts)
   ,(strCI "mcfg-old", PrtOld.prt . CnvOld.mcfg . statePInfoOld)
   ,(strCI "cfg-old",  PrtOld.prt . CnvOld.cfg . statePInfoOld)
   ] 
+  where stateGrammarLangOpts s = (stateOptions s, stateGrammarLang s)
+
 
 customMultiGrammarPrinter = 
   customData "Printers for multiple grammars, selected by option -printer=x" $