FCFG format in BNFC

1 files changed, 100 insertions, 0 deletions

diff --git a/src/GF/FCFG/ToFCFG.hs b/src/GF/FCFG/ToFCFG.hs
new file mode 100644
index 000000000..7e19fefc5
--- /dev/null
+++ b/src/GF/FCFG/ToFCFG.hs
@@ -0,0 +1,100 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- mapping from GF-internal FGrammar to bnfc-defined FCFG
+-----------------------------------------------------------------------------
+
+module GF.FCFG.ToFCFG (printFGrammar) where
+
+import GF.Formalism.FCFG
+import GF.Formalism.SimpleGFC
+import GF.Conversion.Types
+import GF.Infra.Ident
+import qualified GF.FCFG.AbsFCFG as F
+
+import GF.FCFG.PrintFCFG (printTree)
+
+import qualified GF.Canon.AbsGFC as C
+
+import Control.Monad (liftM)
+import Data.List (groupBy)
+import Data.Array
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+
+import GF.Infra.Print
+
+
+-- this is the main function used
+printFGrammar :: FCFGrammar FCat Name Token -> String
+printFGrammar = printTree . fgrammar
+
+fgrammar :: FCFGrammar FCat Name Token -> F.FGrammar
+fgrammar = F.FGr . map frule
+
+frule :: FCFRule FCat Name Token -> F.FRule
+frule (FRule ab rhs) = 
+  F.FR (abstract ab) [[fsymbol sym | (_,sym) <- assocs syms] | (_,syms) <- assocs rhs]
+
+abstract :: Abstract FCat Name -> F.Abstract
+abstract (Abs cat cats n) = F.Abs (fcat cat) (map fcat cats) (name n)
+
+fsymbol :: FSymbol FCat Token -> F.FSymbol
+fsymbol fs = case fs of
+  FSymCat fc i j -> F.FSymCat (fcat fc) (toInteger i) (toInteger j)
+  FSymTok s -> F.FSymTok s
+
+fcat :: FCat -> F.FCat
+fcat (FCat i id ps pts) = 
+  F.FC (toInteger i) (ident id) [map pathel p | Path p <- ps] 
+    [F.PtT (map pathel p) (term t) | (Path p,t) <- pts]
+
+name :: Name -> F.Name
+name (Name id profs) = F.Nm (ident id) (map profile profs)
+
+pathel :: Either C.Label (Term SCat Token) -> F.PathEl
+pathel lt = case lt of
+  Left lab -> F.PLabel $ label lab
+  Right trm -> F.PTerm $ term trm
+
+path (Path p) = map pathel p
+
+profile :: Profile (SyntaxForest Fun) -> F.Profile
+profile p = case p of
+  Unify is -> F.Unify (map toInteger is)
+  Constant sf -> F.Const (forest sf)
+
+forest :: SyntaxForest Fun -> F.Forest
+forest f = case f of
+  FMeta -> F.FMeta
+  FNode id fss -> F.FNode (ident id) (map (map forest) fss)
+  FString s -> F.FString s
+  FInt i -> F.FInt i
+  FFloat d -> F.FFloat d
+
+term :: Term SCat Token -> F.Term
+term tr = case tr of
+  Arg i id p -> F.Arg (toInteger i) (ident id) (path p)
+  Rec rs -> F.Rec [F.Ass (label l) (term t) | (l,t) <- rs]
+  Tbl cs -> F.Tbl [F.Cas (term p) (term v) | (p,v) <- cs]
+  c :^ ts -> F.Constr (constr c) (map term ts)
+  t :. l -> F.Proj (term t) (label l)
+  t :++ u -> F.Concat (term t) (term u)
+  t :! u -> F.Select (term t) (term u)
+  Variants ts -> F.Vars $ map term ts
+  Token s -> F.Tok s
+  Empty -> F.Empty
+
+label :: C.Label -> F.Label
+label b = case b of
+  C.L x -> F.L $ ident x
+  C.LV i -> F.LV i
+
+ident :: Ident -> F.Ident
+ident = F.Ident . prIdent --- is information lost?
+
+constr (C.CIQ m c) = F.CIQ (ident m) (ident c)