refactored FCFG parsing to fit in GFCC shell

src/GF/Conversion/FTypes.hs

@@ -0,0 +1,64 @@
+module GF.Conversion.FTypes where
+
+import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
+import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC (CId(..))
+
+import GF.Formalism.FCFG
+import GF.Formalism.Utilities
+import GF.Infra.PrintClass
+import GF.Data.Assoc
+
+import Control.Monad (foldM)
+import Data.Array
+
+----------------------------------------------------------------------
+-- * basic (leaf) types
+
+-- ** input tokens
+
+---- type Token = String ---- inlined in FGrammar and FRule
+
+
+----------------------------------------------------------------------
+-- * fast nonerasing MCFG
+
+type FIndex   = Int
+type FPath    = [FIndex]
+type FName    = NameProfile AbsGFCC.CId
+type FGrammar = FCFGrammar FCat FName String
+type FRule    = FCFRule    FCat FName String
+data FCat     = FCat  {-# UNPACK #-} !Int AbsGFCC.CId [FPath] [(FPath,FIndex)]
+
+initialFCat :: AbsGFCC.CId -> FCat
+initialFCat cat = FCat 0 cat [] []
+
+fcatString = FCat (-1) (AbsGFCC.CId "String") [[0]] []
+fcatInt    = FCat (-2) (AbsGFCC.CId "Int")    [[0]] []
+fcatFloat  = FCat (-3) (AbsGFCC.CId "Float")  [[0]] []
+
+fcat2cid :: FCat -> AbsGFCC.CId
+fcat2cid (FCat _ c _ _) = c
+
+instance Eq FCat where
+  (FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
+
+instance Ord FCat where
+  compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
+
+instance Print AbsGFCC.CId where
+  prt (AbsGFCC.CId s) = s
+
+isCoercionF :: FName -> Bool
+isCoercionF (Name fun [Unify [0]]) = fun == AbsGFCC.CId "_"
+isCoercionF _ = False
+
+
+----------------------------------------------------------------------
+-- * pretty-printing
+
+instance Print FCat where
+    prt (FCat _ (AbsGFCC.CId cat) rcs tcs) = cat ++ "{" ++ 
+			             prtSep ";" ([prt path                    |  path       <- rcs] ++
+			                         [prt path ++ "=" ++ prt term | (path,term) <- tcs])
+			                 ++ "}"
+

src/GF/Conversion/GFC.hs

@@ -25,6 +25,7 @@ import GF.Formalism.SimpleGFC (decl2cat)
 import GF.Formalism.CFG (CFRule(..))
 import GF.Formalism.Utilities (symbol, name2fun)
 import GF.Conversion.Types
+import GF.Conversion.FTypes
 
 import qualified GF.Conversion.GFCtoSimple as G2S
 import qualified GF.Conversion.SimpleToFinite as S2Fin

src/GF/Conversion/SimpleToFCFG.hs

@@ -13,17 +13,17 @@
 
 
 module GF.Conversion.SimpleToFCFG
-    (convertGrammar) where
+    (convertGrammar,convertGrammarCId,FCat(..)) where
 
 import GF.System.Tracing
-import GF.Infra.Print
+import GF.Infra.PrintClass
 import GF.Infra.Ident
 
 import Control.Monad
 
 import GF.Formalism.Utilities
 import GF.Formalism.FCFG
-import GF.Conversion.Types
+import GF.Conversion.FTypes
 import GF.Canon.GFCC.AbsGFCC
 import GF.Canon.GFCC.DataGFCC
 
@@ -40,17 +40,27 @@ import Data.Maybe
 ----------------------------------------------------------------------
 -- main conversion function
 
-convertGrammar :: Grammar -> [(Ident,FGrammar)]
-convertGrammar g@(Grm hdr (Abs abs_defs) cncs) = [(i2i cncname,convert abs_defs conc) | cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)]
+type FToken = String
+
+convertGrammar :: Grammar -> [(Ident,FCFGrammar FCat FName FToken)]
+convertGrammar g = [(IC c, f) | (CId c,f) <- convertGrammarCId (mkGFCC g)]
+
+-- this is more native for GFCC
+
+convertGrammarCId :: GFCC -> [(CId,FCFGrammar FCat FName FToken)]
+convertGrammarCId gfcc = [(cncname,convert abs_defs conc) | 
+    cncname <- cncnames gfcc, conc <- Map.lookup cncname (concretes gfcc)]
   where
-    gfcc = mkGFCC g
 
-    i2i (CId i) = IC i
+    abs_defs = Map.assocs (funs (abstract gfcc))
 
-    convert :: [AbsDef] -> TermMap -> FGrammar
+    convert :: [(CId,Type)] -> TermMap -> FGrammar
     convert abs_defs cnc_defs = getFRules (loop frulesEnv)
       where
-        srules = [(XRule id args res (map findLinType args) (findLinType res) term) | Fun id (Typ args res) exp <- abs_defs, term <- Map.lookup id cnc_defs]
+        srules = [
+          (XRule id args res (map findLinType args) (findLinType res) term) | 
+            (id, Typ args res) <- abs_defs, 
+            term <- Map.lookup id cnc_defs]
         
         findLinType (CId id) = fromJust (Map.lookup (CId ("__"++id)) cnc_defs)
 
@@ -119,7 +129,7 @@ translateLin idxArgs lbl' ((lbl,syms) : lins)
 type CnvMonad a = BacktrackM Env a
 
 type Env     = (FCat, [(FCat,[FPath])], Term, [Term])
-type LinRec  = [(FPath, [Symbol (FPath, FIndex, Int) Token])]
+type LinRec  = [(FPath, [Symbol (FPath, FIndex, Int) FToken])]
 
 type TermMap = Map.Map CId Term
 

src/GF/Conversion/Types.hs

@@ -14,6 +14,8 @@
 
 module GF.Conversion.Types where
 
+---import GF.Conversion.FTypes
+
 import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
 import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
 import qualified GF.Canon.GFCC.AbsGFCC as AbsGFCC (CId(..))
@@ -110,31 +112,8 @@ mcat2scat = ecat2scat . mcat2ecat
 ----------------------------------------------------------------------
 -- * fast nonerasing MCFG
 
-type FIndex   = Int
-type FPath    = [FIndex]
-type FName    = NameProfile AbsGFCC.CId
-type FGrammar = FCFGrammar FCat FName Token
-type FRule    = FCFRule    FCat FName Token
-data FCat     = FCat  {-# UNPACK #-} !Int AbsGFCC.CId [FPath] [(FPath,FIndex)]
+---- moved to FTypes by AR 20/9/2007
 
-initialFCat :: AbsGFCC.CId -> FCat
-initialFCat cat = FCat 0 cat [] []
-
-fcatString = FCat (-1) (AbsGFCC.CId "String") [[0]] []
-fcatInt    = FCat (-2) (AbsGFCC.CId "Int")    [[0]] []
-fcatFloat  = FCat (-3) (AbsGFCC.CId "Float")  [[0]] []
-
-fcat2cid :: FCat -> AbsGFCC.CId
-fcat2cid (FCat _ c _ _) = c
-
-instance Eq FCat where
-  (FCat id1 _ _ _) == (FCat id2 _ _ _) = id1 == id2
-
-instance Ord FCat where
-  compare (FCat id1 _ _ _) (FCat id2 _ _ _) = compare id1 id2
-
-instance Print AbsGFCC.CId where
-  prt (AbsGFCC.CId s) = s
 
 ----------------------------------------------------------------------
 -- * CFG
@@ -163,9 +142,5 @@ instance Print MCat where
 instance Print CCat where
     prt (CCat cat label) = prt cat ++ prt label
 
-instance Print FCat where
-    prt (FCat _ (AbsGFCC.CId cat) rcs tcs) = cat ++ "{" ++ 
-			             prtSep ";" ([prt path                    |  path       <- rcs] ++
-			                         [prt path ++ "=" ++ prt term | (path,term) <- tcs])
-			                 ++ "}"
+---- instance Print FCat where ---- FCat