"Committed_by_peb"

5 files changed, 112 insertions, 82 deletions

diff --git a/src/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs
index 9e0b58be1..d0b3ea9d3 100644
--- a/src/GF/Conversion/GFC.hs
+++ b/src/GF/Conversion/GFC.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/09 09:28:43 $ 
+-- > CVS $Date: 2005/05/13 12:40:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.8 $
+-- > CVS $Revision: 1.9 $
 --
 -- All conversions from GFC 
 -----------------------------------------------------------------------------
@@ -22,7 +22,7 @@ import GF.Infra.Ident (Ident, identC)
 import GF.Formalism.GCFG (Rule(..), Abstract(..))
 import GF.Formalism.SimpleGFC (decl2cat)
 import GF.Formalism.CFG (CFRule(..))
-import GF.Formalism.Utilities (symbol)
+import GF.Formalism.Utilities (symbol, name2fun)
 import GF.Conversion.Types
 
 import qualified GF.Conversion.GFCtoSimple as G2S
@@ -89,7 +89,7 @@ gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun]
 gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) |
 		    Rule (Abs decl decls name) _ <- gfc2simple gr ]
 
-abstract2prolog :: [Abstract SCat Fun] -> String
+abstract2prolog :: [Abstract SCat Fun] -> String
 abstract2prolog gr = skvatt_hdr ++ concatMap abs2pl gr
     where abs2pl (Abs cat [] fun) = prtQuoted cat ++ " ---> " ++ 
 				    "\"" ++ prt fun ++ "\".\n"
diff --git a/src/GF/Conversion/GFCtoSimple.hs b/src/GF/Conversion/GFCtoSimple.hs
index e7a3789a4..c238eabfe 100644
--- a/src/GF/Conversion/GFCtoSimple.hs
+++ b/src/GF/Conversion/GFCtoSimple.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/10 12:52:06 $ 
+-- > CVS $Date: 2005/05/13 12:40:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.7 $
+-- > CVS $Revision: 1.8 $
 --
 -- Converting GFC to SimpleGFC
 --
@@ -24,6 +24,7 @@ import qualified GF.Canon.AbsGFC as A
 import qualified GF.Infra.Ident as I
 import GF.Formalism.GCFG
 import GF.Formalism.SimpleGFC 
+import GF.Formalism.Utilities
 import GF.Conversion.Types
 
 import GF.Canon.GFC (CanonGrammar)
diff --git a/src/GF/Conversion/SimpleToFinite.hs b/src/GF/Conversion/SimpleToFinite.hs
index 7cefd7844..adc8afc78 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/21 16:21:54 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.5 $
+-- > CVS $Date: 2005/05/13 12:40:19 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.6 $
 --
 -- Calculating the finiteness of each type in a grammar
 -----------------------------------------------------------------------------
@@ -19,6 +19,7 @@ import GF.Infra.Print
 
 import GF.Formalism.GCFG
 import GF.Formalism.SimpleGFC
+import GF.Formalism.Utilities 
 import GF.Conversion.Types
 
 import GF.Data.SortedList
diff --git a/src/GF/Conversion/SimpleToMCFG/Nondet.hs b/src/GF/Conversion/SimpleToMCFG/Nondet.hs
index 12db9511c..22970bd84 100644
--- a/src/GF/Conversion/SimpleToMCFG/Nondet.hs
+++ b/src/GF/Conversion/SimpleToMCFG/Nondet.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/09 09:28:44 $ 
+-- > CVS $Date: 2005/05/13 12:40:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.5 $
+-- > CVS $Revision: 1.6 $
 --
 -- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
 -- Afterwards, the grammar has to be extended with coercion functions,
@@ -60,7 +60,7 @@ convertGrammar rules = traceCalcFirst rules' $
 
 convertRule :: SRule -> [ERule] -- CnvMonad ERule
 convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) =
---    | prt(name2fun fun) `elem` 
+--    | prt(name2fun fun) `elem` 
 --      words "UseCl PosTP TPast ASimul SPredV IndefOneNP DefOneNP UseN2 mother_N2 jump_V" =
     if notLongerThan maxNrRules rules 
        then tracePrt ("SimpeToMCFG.Nondet - MCFG rules for " ++ prt fun) (prt . length) $
@@ -78,7 +78,7 @@ convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) =
 			 catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
 		     -- checkLinRec argsPaths catPaths newLinRec
 		     return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec) 
-convertRule _ = [] -- failure
+convertRule _ = [] -- failure
 
 
 ----------------------------------------------------------------------
diff --git a/src/GF/Conversion/Types.hs b/src/GF/Conversion/Types.hs
index c233ca69d..03afeab40 100644
--- a/src/GF/Conversion/Types.hs
+++ b/src/GF/Conversion/Types.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/09 09:28:44 $ 
+-- > CVS $Date: 2005/05/13 12:40:19 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.8 $
+-- > CVS $Revision: 1.9 $
 --
 -- All possible instantiations of different grammar formats used in conversion from GFC
 -----------------------------------------------------------------------------
@@ -27,6 +27,7 @@ import GF.Infra.Print
 import GF.Data.Assoc
 
 import Control.Monad (foldM)
+import Data.List (intersperse)
 
 ----------------------------------------------------------------------
 -- * basic (leaf) types
@@ -38,67 +39,7 @@ type Token = String
 -- ** function names
 
 type Fun  = Ident.Ident
-data Name = Name Fun [Profile (SyntaxForest Fun)]
-	    deriving (Eq, Ord, Show)
-
-name2fun :: Name -> Fun
-name2fun (Name fun _) = fun
-
-----------------------------------------------------------------------
--- * profiles
-
--- | A profile is a simple representation of a function on a number of arguments.
--- We only use lists of profiles
-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,
-	       | 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 arguments 
--- (i.e. denoting a constant, not a function)
-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 (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 (Constant a) = return a
-
--- | profile composition: 
--- 
--- >   applyProfile u z (ps `composeProfiles` qs) args
--- >      ==
--- >   applyProfile u z ps (applyProfile u z qs args)
---
--- compare with function composition
---
--- >   (p . q) arg
--- >      ==
--- >   p (q arg)
---
--- 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 constant    = constant
-
+type Name = NameProfile Fun
 
 
 ----------------------------------------------------------------------
@@ -191,12 +132,99 @@ instance Print MCat where
 instance Print CCat where
     prt (CCat cat label) = prt cat ++ prt label
 
-instance Print Name where
-    prt (Name fun profile) = prt fun ++ prt profile
 
-instance Print a => Print (Profile a) where
-    prt (Unify [])   = "?"
-    prt (Unify args) = prtSep "=" args
-    prt (Constant a) = prt a
+----------------------------------------------------------------------
+-- * other printing facilities
+
+-- ** printing grammars as Haskell files
+
+prtHsSGrammar :: SGrammar -> String
+prtHsSGrammar rules = "-- Simple GFC grammar as a Haskell file\n" ++
+		"-- autogenerated from the Grammatical Framework\n\n" ++
+                "import GF.Formalism.GCFG\n" ++
+		"import GF.Formalism.SimpleGFC\n" ++ 
+                "import GF.Formalism.Utilities\n" ++
+		"--import GF.Conversion.Types\n" ++
+		"import GF.Canon.AbsGFC (CIdent(..), Label(..))\n" ++
+		"import GF.Infra.Ident (Ident(..))\n" ++
+		"\ngrammar :: SimpleGrammar Ident (NameProfile Ident) String\n" ++ 
+		-- "\ngrammar :: SGrammar\n" ++
+		"grammar = \n\t[ " ++ 
+		concat (intersperse "\n\t, " (map show rules)) ++
+                "\n\t]\n\n"
+
+prtHsMGrammar :: MGrammar -> String
+prtHsMGrammar rules = "-- Multiple context-free grammar as a Haskell file\n" ++
+		      "-- autogenerated from the Grammatical Framework\n\n" ++
+		      "import GF.Formalism.GCFG\n" ++ 
+		      "import GF.Formalism.MCFG\n" ++ 
+                      "import GF.Formalism.Utilities\n" ++
+                      "\ngrammar :: MCFGrammar String (NameProfile String) String String\n" ++
+		      "grammar = \n\t[ " ++ 
+		      concat (intersperse "\n\t, " (map prtHsMRule rules)) ++
+                      "\n\t]\n\n" 
+    where prtHsMRule (Rule (Abs cat cats (Name fun profiles)) (Cnc lcat lcats lins)) =
+	      show (Rule (Abs (prt cat) (map prt cats) (Name (prt fun) (map cnvHsProfile profiles)))
+		         (Cnc (map prt lcat) (map (map prt) lcats) (map cnvHsLin lins)))
+	  cnvHsLin (Lin lbl syms) = Lin (prt lbl) (map (mapSymbol prtMArg id) syms)
+	  prtMArg  (cat, lbl, nr) = (prt cat, prt lbl, nr)
+
+prtHsCGrammar :: CGrammar -> String
+prtHsCGrammar rules = "-- Context-free grammar as a Haskell file\n" ++
+		      "-- autogenerated from the Grammatical Framework\n\n" ++
+		      "import GF.Formalism.CFG\n" ++ 
+                      "import GF.Formalism.Utilities\n" ++
+                      "\ngrammar :: CFGrammar String (NameProfile String) String\n" ++
+		      "grammar = \n\t[ " ++ 
+		      concat (intersperse "\n\t, " (map prtHsCRule rules)) ++
+                      "\n\t]\n\n" 
+    where prtHsCRule (CFRule cat syms (Name fun profiles)) = 
+	      show (CFRule (prt cat) (map (mapSymbol prt id) syms) 
+	                   (Name (prt fun) (map cnvHsProfile profiles)))
+
+cnvHsProfile (Unify args) = Unify args
+cnvHsProfile (Constant forest) = Constant (fmap prt forest)
+
+-- ** printing grammars as Prolog files
+
+prtPlMGrammar :: MGrammar -> String
+prtPlMGrammar rules = ":- op(1100, xfx, ':=').\n" ++ 
+		      ":- op(1000, xfx, '--->').\n" ++ 
+		      ":- op(200, xfx, '@').\n\n" ++ 
+		      "%% Fun/ProfileList : Cat ---> [Cat,...] := [Lbl=SymbolList,...]\n" ++
+		      concatMap prtPlMRule rules
+    where prtPlMRule (Rule (Abs cat cats (Name fun profiles)) (Cnc _lcat _lcats lins)) =
+	      prtPlQuoted fun ++ "/" ++ 
+	      "[" ++ prtSep "," (map prtPlProfile profiles) ++ "] : " ++
+	      prtPlQuoted cat ++ " ---> " ++ 
+	      "[" ++ prtSep ", " (map prtPlQuoted cats) ++ "] := \n" ++
+	      "\t[ " ++ prtSep "\n\t, " (map prtLin lins) ++ "\n\t].\n"
+	  prtLin (Lin lbl lin) = prtPlQuoted lbl ++ " = " ++ 
+				 "[" ++ prtSep ", " (map prtSymbol lin) ++ "]"
+	  prtSymbol (Cat (cat, lbl, nr)) = prtPlQuoted cat ++ "@" ++ show nr ++ "-" ++ prtPlQuoted lbl 
+	  prtSymbol (Tok tok) = "[" ++ prtPlQuoted tok ++ "]"
+
+prtPlCGrammar :: CGrammar -> String
+prtPlCGrammar rules = ":- op(1000, xfx, '--->').\n\n" ++ 
+		      "%% Fun/ProfileList : Cat ---> [Symbol,...]\n" ++
+		      concatMap prtPlCRule rules
+    where prtPlCRule (CFRule cat syms (Name fun profiles)) = 
+	      prtPlQuoted fun ++ "/" ++
+	      "[" ++ prtSep "," (map prtPlProfile profiles) ++ "] : " ++
+	      prtPlQuoted cat ++ " ---> " ++ 
+	      "[" ++ prtSep ", " (map prtSymbol syms) ++ "].\n"
+	  prtSymbol (Cat cat) = prtPlQuoted cat 
+	  prtSymbol (Tok tok) = "[" ++ prtPlQuoted tok ++ "]"
+
+prtPlProfile (Unify args) = show args
+prtPlProfile (Constant forest) = prtPlForest forest
+
+prtPlForest (FMeta) = "_META_"
+prtPlForest (FNode fun fss) = prtPlQuoted fun ++ "^" ++ prtFss fss
+    where prtFss fss = "[" ++ prtSep "," (map prtFs fss) ++ "]"
+	  prtFs fs = "[" ++ prtSep "," (map prtPlForest fs) ++ "]"
+
+prtPlQuoted str = "'" ++ prt str ++ "'"
+