the other direction of FCFG translation

src/GF/FCFG/FromFCFG.hs

@@ -0,0 +1,105 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- mapping to GF-internal FGrammar from bnfc-defined FCFG
+-----------------------------------------------------------------------------
+
+module GF.FCFG.ToFCFG (getFGrammar) 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.ParFCFG (pFGrammar, myLexer)
+
+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.Data.Operations
+import GF.Infra.Print
+
+
+-- this is the main function used
+getFGrammar :: FilePath -> IO (FCFGrammar FCat Name Token)
+getFGrammar f = 
+  readFile f >>= err error (return . fgrammar) . pFGrammar . myLexer
+
+fgrammar :: F.FGrammar -> FCFGrammar FCat Name Token
+fgrammar (F.FGr rs) = map frule rs
+
+frule :: F.FRule -> FCFRule FCat Name Token 
+frule (F.FR ab rhs) = 
+  FRule (abstract ab) 
+    (arr [arr [fsymbol sym | sym <- syms] | syms <- rhs])
+
+arr xs = listArray (0,length xs - 1) xs
+
+abstract :: F.Abstract -> Abstract FCat Name 
+abstract (F.Abs cat cats n) = Abs (fcat cat) (map fcat cats) (name n)
+
+fsymbol :: F.FSymbol -> FSymbol FCat Token 
+fsymbol fs = case fs of
+  F.FSymCat fc i j -> FSymCat (fcat fc) (fromInteger i) (fromInteger j)
+  F.FSymTok s -> FSymTok s
+
+fcat :: F.FCat -> FCat
+fcat (F.FC i id ps pts) = 
+  FCat (fromInteger i) (ident id) (map path ps)
+    [ (path p, term t) | F.PtT p t <- pts]
+
+name :: F.Name -> Name
+name (F.Nm id profs) = Name (ident id) (map profile profs)
+
+pathel :: F.PathEl -> Either C.Label (Term SCat Token)
+pathel lt = case lt of
+  F.PLabel lab -> Left $ label lab
+  F.PTerm trm -> Right $ term trm
+
+path = Path . map pathel
+
+profile :: F.Profile -> Profile (SyntaxForest Fun)
+profile p = case p of
+  F.Unify is -> Unify (map fromInteger is)
+  F.Const sf -> Constant (forest sf)
+
+forest :: F.Forest -> SyntaxForest Fun
+forest f = case f of
+  F.FMeta -> FMeta
+  F.FNode id fss -> FNode (ident id) (map (map forest) fss)
+  F.FString s -> FString s
+  F.FInt i -> FInt i
+  F.FFloat d -> FFloat d
+
+term :: F.Term -> Term SCat Token 
+term tr = case tr of
+  F.Arg i id p -> Arg (fromInteger i) (ident id) (path p)
+  F.Rec rs -> Rec [(label l, term t) | F.Ass l t <- rs]
+  F.Tbl cs -> Tbl [(term p, term v) | F.Cas p v <- cs]
+  F.Constr c ts -> (constr c) :^ (map term ts)
+  F.Proj t l -> (term t) :. (label l)
+  F.Concat t u -> (term t) :++ (term u)
+  F.Select t u -> (term t) :! (term u)
+  F.Vars ts -> Variants $ map term ts
+  F.Tok s -> Token s
+  F.Empty -> Empty
+
+label :: F.Label -> C.Label
+label b = case b of
+  F.L x -> C.L $ ident x
+  F.LV i -> C.LV i
+
+ident :: F.Ident -> Ident
+ident (F.Ident x) = identC x --- should other constructors be used?
+
+constr (F.CIQ m c) = C.CIQ (ident m) (ident c)