embedded parser in MultiGrammar in GFCCAPI

src/GF/Canon/GFCC/FCFGParsing.hs

@@ -1,4 +1,4 @@
-module GF.Canon.GFCC.FCFGParsing (parserLang) where
+module GF.Canon.GFCC.FCFGParsing (parserLang,buildPInfo,FCFPInfo) where
 
 import GF.Canon.GFCC.DataGFCC
 import GF.Canon.GFCC.AbsGFCC
@@ -52,7 +52,7 @@ wordsCFTok :: CFTok -> [String]
 wordsCFTok = return ----
 
 
-type FCFPInfo = PF.FCFPInfo FCat FName Token
+type FCFPInfo = PF.FCFPInfo FCat FName String
 
 buildPInfo :: FGrammar -> FCFPInfo
 buildPInfo fcfg = PF.buildFCFPInfo grammarLexer fcfg where
@@ -130,7 +130,7 @@ tree2term (TMeta)      = Macros.mkMeta 0
 -- conversion and unification of forests
 
 -- simplest implementation
-applyProfileToForest :: SyntaxForest Name -> [SyntaxForest Fun]
+applyProfileToForest :: SyntaxForest FName -> [SyntaxForest Fun]
 applyProfileToForest (FNode name@(Name fun profile) children) 
     | isCoercionF name = concat chForests
     | otherwise       = [ FNode fun chForests | not (null chForests) ]

src/GF/Canon/GFCC/GFCCAPI.hs

@@ -22,6 +22,8 @@ import GF.Canon.GFCC.ParGFCC
 import GF.Canon.GFCC.PrintGFCC
 import GF.Canon.GFCC.ErrM
 import GF.Canon.GFCC.FCFGParsing
+import GF.Conversion.SimpleToFCFG (convertGrammarCId,FCat(..))
+
 --import GF.Data.Operations
 --import GF.Infra.UseIO
 import qualified Data.Map as Map
@@ -37,7 +39,7 @@ import System
 -- Interface
 ---------------------------------------------------
 
-type MultiGrammar = GFCC
+data MultiGrammar = MultiGrammar {gfcc :: GFCC, parsers :: [(Language,FCFPInfo)]}
 type Language     = String
 type Category     = String
 type Tree         = Exp
@@ -65,14 +67,18 @@ startCat   :: MultiGrammar -> Category
 -- Implementation
 ---------------------------------------------------
 
-file2grammar f =
+file2grammar f = do
+  gfcc <- file2gfcc f
+  let fcfgs = convertGrammarCId gfcc
+  return (MultiGrammar gfcc [(lang, buildPInfo fcfg) | (CId lang,fcfg) <- fcfgs])
+
+file2gfcc f =
   readFileIf f >>= err (error "no parse") (return . mkGFCC) . pGrammar . myLexer
 
-linearize mgr lang = GF.Canon.GFCC.DataGFCC.linearize mgr (CId lang)
-
+linearize mgr lang = GF.Canon.GFCC.DataGFCC.linearize (gfcc mgr) (CId lang)
 
 parse mgr lang cat s = 
-  err error id $ parserLang mgr (CId lang) (CId cat) (words s)
+  err error id $ parserLang (gfcc mgr) (CId lang) (CId cat) (words s)
 
 {-
   map tree2exp . 
@@ -85,7 +91,8 @@ parse mgr lang cat s =
 -}
 
 linearizeAll mgr = map snd . linearizeAllLang mgr
-linearizeAllLang mgr t = [(lang,linearThis mgr lang t) | lang <- languages mgr]
+linearizeAllLang mgr t = 
+  [(lang,linearThis mgr lang t) | lang <- languages mgr]
 
 {-
 parseAll mgr cat = map snd . parseAllLang mgr cat
@@ -98,9 +105,9 @@ readTree _ = err (const exp0) id . (pExp . myLexer)
 
 showTree t = printTree t
 
-languages mgr = [l | CId l <- cncnames mgr]
+languages mgr = [l | CId l <- cncnames (gfcc mgr)]
 
-categories mgr = [c | CId c <- Map.keys (cats (abstract mgr))]
+categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))]
 
 startCat mgr = "S" ----
 

src/GF/Canon/GFCC/Shell.hs

@@ -25,7 +25,7 @@ loop grammar = do
     loop grammar
 
 treat :: MultiGrammar -> String -> IO ()
-treat grammar s = case words s of
+treat mgr s = case words s of
   "gt":cat:n:_ -> do
     mapM_ prlinonly $ take (read n) $ G.generate grammar (CId cat)
   "gtt":cat:n:_ -> do
@@ -37,21 +37,22 @@ treat grammar s = case words s of
     gen <- newStdGen
     mapM_ prlin $ take (read n) $ G.generateRandom gen grammar (CId cat)
   "p":lang:cat:ws -> do
-    let ts = parse grammar lang cat $ unwords ws
+    let ts = parse mgr lang cat $ unwords ws
     mapM_ (putStrLn . showTree) ts 
   "search":cat:n:ws -> do
     case G.parse (read n) grammar (CId cat) ws of
       t:_ -> prlin t
       _ -> putStrLn "no parse found" 
-  _ -> lins $ readTree grammar s
+  _ -> lins $ readTree mgr s
  where
-  langs = languages grammar
+  grammar = gfcc mgr
+  langs = languages mgr
   lins t = mapM_ (lint t) $ langs 
   lint t lang = do
 ----    putStrLn $ showTree $ linExp grammar lang t 
     lin t lang
   lin t lang = do
-    putStrLn $ linearize grammar lang t
+    putStrLn $ linearize mgr lang t
   prlins t = do
     putStrLn $ showTree t
     lins t