GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/Conversion/SimpleToMCFG/Coercions.hs

@@ -0,0 +1,63 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/09 09:28:44 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.5 $
+--
+-- Adding coercion functions to a MCFG if necessary.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToMCFG.Coercions
+    (addCoercions) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Conversion.Types 
+import GF.Data.SortedList
+import Data.List (groupBy)
+
+----------------------------------------------------------------------
+
+addCoercions :: EGrammar -> EGrammar
+addCoercions rules = coercions ++ rules
+    where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | 
+					Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
+	  allHeadSet = nubsort allHeads
+	  allArgSet  = union   allArgs <\\> map fst allHeadSet
+	  coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $
+		      concat $
+		      tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category" 
+				   (prtList . map length) $
+		      combineCoercions 
+		        (groupBy sameECatFst allHeadSet) 
+			(groupBy sameECat    allArgSet)
+	  sameECatFst a b = sameECat (fst a) (fst b)
+
+
+combineCoercions [] _ = []
+combineCoercions _ [] = []
+combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) 
+    = case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of
+        LT -> combineCoercions allHeads  allArgs'
+	GT -> combineCoercions allHeads' allArgs
+	EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
+
+
+makeCoercion heads args
+    = [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins)  |
+	(head@(ECat _ headCns), lbls) <- heads, 
+	let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
+	arg@(ECat _ argCns) <- args,
+	argCns `subset` headCns ]
+
+
+