Restoring old functionality

3 files changed, 76 insertions, 7 deletions

diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs
index 99ab711e4..95d532e2d 100644
--- a/src/GF/CF/CFIdent.hs
+++ b/src/GF/CF/CFIdent.hs
@@ -68,6 +68,10 @@ varCFFun = mkCFFun . AV
 consCFFun :: CIdent -> CFFun
 consCFFun = mkCFFun . AC
 
+-- standard way of making cf fun
+string2CFFun :: String -> String -> CFFun
+string2CFFun m c = consCFFun $ mkCIdent m c
+
 stringCFFun :: String -> CFFun 
 stringCFFun = mkCFFun . AS
 
@@ -80,6 +84,9 @@ dummyCFFun = varCFFun $ identC "_" --- used in lexer-by-need rules
 cfFun2String :: CFFun -> String
 cfFun2String (CFFun (f,_)) = prt f
 
+cfFun2Ident :: CFFun -> Ident
+cfFun2Ident (CFFun (f,_)) = identC $ prt_ f ---
+
 cfFun2Profile :: CFFun -> Profile
 cfFun2Profile (CFFun (_,p)) = p
 
@@ -131,6 +138,9 @@ moduleOfCFCat (CFCat (CIQ m _, _)) = m
 cfCat2Cat :: CFCat -> (Ident,Ident)
 cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
 
+cfCat2Ident :: CFCat -> Ident
+cfCat2Ident = snd . cfCat2Cat
+
 lexCFCat :: CFCat -> CFCat
 lexCFCat cat = ident2CFCat (uncurry CIQ (cfCat2Cat cat)) (identC "*")
 
diff --git a/src/GF/CF/CFtoGrammar.hs b/src/GF/CF/CFtoGrammar.hs
new file mode 100644
index 000000000..440c4f7c3
--- /dev/null
+++ b/src/GF/CF/CFtoGrammar.hs
@@ -0,0 +1,50 @@
+module CFtoGrammar where
+
+import Ident
+import Grammar
+import qualified AbsGF as A
+import qualified GrammarToSource as S
+import Macros
+
+import CF
+import CFIdent
+import PPrCF
+
+import Operations
+
+import List (nub)
+import Char (isSpace)
+
+-- 26/1/2000 -- 18/4 -- 24/3/2004
+
+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) nope Nothing) | (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 linLabel [foldconcat (map mkIt args0)])))
+               nope)
+ mkIt (v, CFNonterm _) = P (Vr v) (linLabel 0)
+ 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
+
diff --git a/src/GF/CF/PPrCF.hs b/src/GF/CF/PPrCF.hs
index ff4b64e66..91ab240ea 100644
--- a/src/GF/CF/PPrCF.hs
+++ b/src/GF/CF/PPrCF.hs
@@ -6,6 +6,8 @@ import CFIdent
 import AbsGFC
 import PrGrammar
 
+import Char
+
 -- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003
 ---- use the Print class instead!
 
@@ -42,18 +44,25 @@ prRegExp (RegAlts tt) = case tt of
   [t] -> prQuotedString t
   _ -> prParenth (prTList " | " (map prQuotedString tt))
 
-{- ----
 -- rules have an amazingly easy parser, if we use the format
 -- fun. C -> item1 item2 ... where unquoted items are treated as cats
 -- Actually would be nice to add profiles to this.
 
-getCFRule :: String -> Maybe CFRule
-getCFRule s = getcf (wrds s) where
+getCFRule :: String -> String -> Err CFRule
+getCFRule mo s = getcf (wrds s) where
   getcf ww | length ww > 2 && ww !! 2 `elem` ["->", "::="] = 
-            Just (string2CFFun (init fun), (string2CFCat cat, map mkIt its)) where
+       Ok (string2CFFun mo (init fun), (string2CFCat mo cat, map mkIt its)) where
     fun : cat : _ : its = words s
     mkIt ('"':w@(_:_)) = atomCFTerm (string2CFTok (init w))
-    mkIt w = CFNonterm (string2CFCat w)
-  getcf _ = Nothing
+    mkIt w = CFNonterm (string2CFCat mo w)
+  getcf _ = Bad "invalid rule"
   wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
--}
\ No newline at end of file
+
+pCF :: String -> String -> Err CF
+pCF mo s = do
+  rules <- mapM (getCFRule mo) $ filter isRule $ lines s
+  return $ rules2CF rules
+ where
+   isRule line = case line of
+     '-':'-':_ -> False
+     _ -> not $ all isSpace line