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

1 files changed, 62 insertions, 0 deletions

diff --git a/src-3.0/GF/CF/CFtoGrammar.hs b/src-3.0/GF/CF/CFtoGrammar.hs
new file mode 100644
index 000000000..5e73aec31
--- /dev/null
+++ b/src-3.0/GF/CF/CFtoGrammar.hs
@@ -0,0 +1,62 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CFtoGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:09 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- 26\/1\/2000 -- 18\/4 -- 24\/3\/2004
+-----------------------------------------------------------------------------
+
+module GF.CF.CFtoGrammar (cf2grammar) where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import qualified GF.Source.AbsGF as A
+import qualified GF.Source.GrammarToSource as S
+import GF.Grammar.Macros
+
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.CF.PPrCF
+
+import GF.Data.Operations
+
+import Data.List (nub)
+import Data.Char (isSpace)
+
+cf2grammar :: CF -> [A.TopDef]
+cf2grammar cf = concatMap S.trAnyDef (abs ++ conc) where
+  rules = rulesOfCF cf
+  abs   = cats ++ funs
+  conc  = lintypes ++ lins
+  cats  = [(cat, AbsCat (yes []) (yes [])) | 
+             cat <- nub (concat (map cf2cat rules))] ----notPredef cat
+  lintypes = [(cat, CncCat (yes defLinType) nope nope) | (cat,AbsCat _ _) <- cats]
+  (funs,lins) = unzip (map cf2rule rules)
+
+cf2cat :: CFRule -> [Ident]
+cf2cat (_,(cat, items)) = map cfCat2Ident $ cat : [c | CFNonterm c <- items]
+
+cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
+cf2rule (fun, (cat, items)) = (def,ldef) where
+ f     = cfFun2Ident fun
+ def   = (f, AbsFun (yes (mkProd (args', Cn (cfCat2Ident cat), []))) nope)
+ args0 = zip (map (mkIdent "x") [0..]) items
+ args  = [(v, Cn (cfCat2Ident c)) | (v, CFNonterm c) <- args0]
+ args' = [(zIdent "_", Cn (cfCat2Ident c)) | (_, CFNonterm c) <- args0]
+ ldef  = (f, CncFun 
+               Nothing 
+               (yes (mkAbs (map fst args) 
+                      (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
+               nope)
+ mkIt (v, CFNonterm _) = P (Vr v) theLinLabel
+ mkIt (_, CFTerm (RegAlts [a])) = K a
+ mkIt _ = K "" --- regexp not recognized in input CF ; use EBNF for this
+ foldconcat [] = K ""
+ foldconcat tt = foldr1 C tt
+