FCFG format in BNFC

5 files changed, 525 insertions, 0 deletions

diff --git a/src/GF/FCFG/AbsFCFG.hs b/src/GF/FCFG/AbsFCFG.hs
new file mode 100644
index 000000000..c7b2c4057
--- /dev/null
+++ b/src/GF/FCFG/AbsFCFG.hs
@@ -0,0 +1,82 @@
+module GF.FCFG.AbsFCFG where
+
+-- Haskell module generated by the BNF converter
+
+newtype Ident = Ident String deriving (Eq,Ord,Show)
+data FGrammar =
+   FGr [FRule]
+  deriving (Eq,Ord,Show)
+
+data FRule =
+   FR Abstract [[FSymbol]]
+  deriving (Eq,Ord,Show)
+
+data Abstract =
+   Abs FCat [FCat] Name
+  deriving (Eq,Ord,Show)
+
+data FSymbol =
+   FSymCat FCat Integer Integer
+ | FSymTok String
+  deriving (Eq,Ord,Show)
+
+data FCat =
+   FC Integer Ident [[PathEl]] [PathTerm]
+  deriving (Eq,Ord,Show)
+
+data PathEl =
+   PLabel Label
+ | PTerm Term
+  deriving (Eq,Ord,Show)
+
+data PathTerm =
+   PtT [PathEl] Term
+  deriving (Eq,Ord,Show)
+
+data Name =
+   Nm Ident [Profile]
+  deriving (Eq,Ord,Show)
+
+data Profile =
+   Unify [Integer]
+ | Const Forest
+  deriving (Eq,Ord,Show)
+
+data Forest =
+   FMeta
+ | FNode Ident [[Forest]]
+ | FString String
+ | FInt Integer
+ | FFloat Double
+  deriving (Eq,Ord,Show)
+
+data Term =
+   Arg Integer Ident [PathEl]
+ | Constr CIdent [Term]
+ | Rec [Assoc]
+ | Proj Term Label
+ | Tbl [Case]
+ | Select Term Term
+ | Vars [Term]
+ | Concat Term Term
+ | Tok String
+ | Empty
+  deriving (Eq,Ord,Show)
+
+data Case =
+   Cas Term Term
+  deriving (Eq,Ord,Show)
+
+data Assoc =
+   Ass Label Term
+  deriving (Eq,Ord,Show)
+
+data Label =
+   L Ident
+ | LV Integer
+  deriving (Eq,Ord,Show)
+
+data CIdent =
+   CIQ Ident Ident
+  deriving (Eq,Ord,Show)
+
diff --git a/src/GF/FCFG/FCFG.cf b/src/GF/FCFG/FCFG.cf
new file mode 100644
index 000000000..a0b375083
--- /dev/null
+++ b/src/GF/FCFG/FCFG.cf
@@ -0,0 +1,131 @@
+-- a portable format for FCFG (Peter Ljunglöf's MCFG modified by Krasimir Anglelov)
+-- Aarne Ranta September 2006
+
+FGr.     FGrammar ::= [FRule] ;
+FR.      FRule    ::= Abstract ":=" [[FSymbol]] ;
+Abs.     Abstract ::= FCat "->" [FCat] "." Name ;
+FSymCat. FSymbol  ::= "(" FCat Integer Integer ")" ;
+FSymTok. FSymbol  ::= String ;
+FC.      FCat     ::= "(" Integer Ident "[" [[PathEl]] "]" "[" [PathTerm] "]" ")" ;
+PLabel.  PathEl   ::= Label ;
+PTerm.   PathEl   ::= Term ;
+PtT.     PathTerm ::= "(" [PathEl] "," Term ")" ;
+Nm.      Name     ::= Ident "[" [Profile] "]" ;
+Unify.   Profile  ::= "[" [Integer] "]" ;
+Const.   Profile  ::= Forest ;
+
+FMeta.   Forest   ::= "?" ;
+FNode.   Forest   ::= "(" Ident [[Forest]] ")" ;
+FString. Forest   ::= String ;
+FInt.    Forest   ::= Integer ;
+FFloat.  Forest   ::= Double ;
+
+Arg.     Term     ::= "(" Integer Ident [PathEl] ")" ;
+Constr.  Term     ::= "(" CIdent "-" [Term] ")" ;
+Rec.     Term     ::= "[" [Assoc] "]" ;
+Proj.    Term     ::= "(" Term "." Label ")" ;
+Tbl.     Term     ::= "[-" [Case] "-]" ;
+Select.  Term     ::= "(" Term "!" Term ")" ;
+Vars.    Term     ::= "[|" [Term] "|]" ;
+Concat.  Term     ::= "(" Term "++" Term ")" ;
+Tok.     Term     ::= String ;
+Empty.   Term     ::= "(" ")" ;
+
+Cas.     Case     ::= Term "=>" Term ;
+Ass.     Assoc    ::= Label "=" Term ;
+
+L.       Label    ::= Ident ;
+LV.      Label    ::= "$" Integer ;
+CIQ.     CIdent   ::= Ident "." Ident ;
+
+terminator FRule ";" ;
+terminator [FSymbol] "|" ;
+terminator FSymbol "" ;
+terminator FCat "" ;
+terminator [Forest] "," ;
+terminator Forest "" ;
+terminator PathTerm "" ;
+terminator Profile "" ;
+terminator Integer "" ;
+terminator Term "," ;
+terminator Assoc "," ;
+terminator Case "," ;
+terminator [PathEl] "," ;
+terminator PathEl "." ;
+
+
+-- type FGrammar  = [FRule]
+-- data FRule     = FRule Abstract (Array Int (Array Int FSymbol))
+-- data Abstract  = Abs FCat [FCat] Name
+-- data FSymbol   = FSymCat FCat Int Int
+--                | FSymTok String
+-- data FCat      = FCat Int Ident [Path] [(Path,Term)]
+-- newtype Path   = Path [Either Label Term]
+-- type Name      = Name Ident [Profile]
+-- type Label     = AbsGFC.Label
+-- data Profile   = Unify [Int] | Constant SyntaxForest
+-- SyntaxForest   = FMeta 
+--		  | FNode Ident [[SyntaxForest]]
+--		  | FString String
+--	          | FInt    Integer
+--	          | FFloat  Double
+{-
+data Term
+    = Arg Int Ident Path       -- ^ argument variable, the 'Path' is a path 
+			         -- pointing into the term 
+    | Constr :^ [Term]       -- ^ constructor
+    | Rec [(Label, Term)]    -- ^ record
+    | Term :. Label          -- ^ record projection
+    | Tbl [(Term, Term)] -- ^ table of patterns\/terms
+    | Term :! Term       -- ^ table selection
+    | Variants [Term]        -- ^ variants
+    | Term :++ Term      -- ^ concatenation
+    | Token String   -- ^ single token
+    | Empty     -- ^ empty string
+-}
+
+
+
+
+
+-- type FGrammar = FCFGrammar  FCat Name Token
+-- type FRule    = FCFRule     FCat Name Token
+-- type FCFGrammar cat name tok = [FCFRule cat name tok]
+-- data FCFRule cat name tok = 
+--   FRule (Abstract cat name) (Array FLabel (Array FPointPos (FSymbol cat tok)))
+-- data Abstract cat name = Abs cat [cat] name
+-- data FSymbol cat tok = FSymCat cat FLabel Int | FSymTok tok
+-- type FLabel    = Int
+-- type FPointPos = Int
+-- data FCat     = FCat Int SCat [SPath] [(SPath,STerm)]
+-- newtype Path c t = Path [Either Label (Term c t)]
+-- type SCat = Ident.Ident
+-- type Fun  = Ident.Ident
+-- type SPath    = Path    SCat Token
+-- type STerm    = Term    SCat Token
+-- type Name = NameProfile Fun
+-- data NameProfile a = Name a [Profile (SyntaxForest a)]
+-- SyntaxForest n = FMeta 
+--		    | FNode n [[SyntaxForest n]]
+--		    | FString String
+--		    | FInt    Integer
+--		    | FFloat  Double
+-- type Token = String
+-- type Label  = AbsGFC.Label
+-- data Profile a = Unify [Int] | Constant a
+-- type Constr = AbsGFC.CIdent
+{-
+data Term c t
+    = Arg Int c (Path c t)       -- ^ argument variable, the 'Path' is a path 
+			         -- pointing into the term 
+    | Constr :^ [Term c t]       -- ^ constructor
+    | Rec [(Label, Term c t)]    -- ^ record
+    | Term c t :. Label          -- ^ record projection
+    | Tbl [(Term c t, Term c t)] -- ^ table of patterns\/terms
+    | Term c t :! Term c t       -- ^ table selection
+    | Variants [Term c t]        -- ^ variants
+    | Term c t :++ Term c t      -- ^ concatenation
+    | Token t   -- ^ single token
+    | Empty     -- ^ empty string
+-}
+
diff --git a/src/GF/FCFG/PrintFCFG.hs b/src/GF/FCFG/PrintFCFG.hs
new file mode 100644
index 000000000..7489227a7
--- /dev/null
+++ b/src/GF/FCFG/PrintFCFG.hs
@@ -0,0 +1,210 @@
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GF.FCFG.PrintFCFG where
+
+-- pretty-printer generated by the BNF converter
+
+import GF.FCFG.AbsFCFG
+import Data.Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "["      :ts -> showChar '[' . rend i ts
+    "("      :ts -> showChar '(' . rend i ts
+    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+    "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
+    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+    ";"      :ts -> showChar ';' . new i . rend i ts
+    t  : "," :ts -> showString t . space "," . rend i ts
+    t  : ")" :ts -> showString t . showChar ')' . rend i ts
+    t  : "]" :ts -> showString t . showChar ']' . rend i ts
+    t        :ts -> space t . rend i ts
+    _            -> id
+  new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+  space t = showString t . (\s -> if null s then "" else (' ':s))
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+  prtList :: [a] -> Doc
+  prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+  prt _ x = doc (shows x)
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
+instance Print Ident where
+  prt _ (Ident i) = doc (showString i)
+
+
+
+instance Print FGrammar where
+  prt i e = case e of
+   FGr frules -> prPrec i 0 (concatD [prt 0 frules])
+
+
+instance Print FRule where
+  prt i e = case e of
+   FR abstract fsymbolss -> prPrec i 0 (concatD [prt 0 abstract , doc (showString ":=") , prt 0 fsymbolss])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Abstract where
+  prt i e = case e of
+   Abs fcat fcats name -> prPrec i 0 (concatD [prt 0 fcat , doc (showString "->") , prt 0 fcats , doc (showString ".") , prt 0 name])
+
+
+instance Print FSymbol where
+  prt i e = case e of
+   FSymCat fcat n0 n -> prPrec i 0 (concatD [doc (showString "(") , prt 0 fcat , prt 0 n0 , prt 0 n , doc (showString ")")])
+   FSymTok str -> prPrec i 0 (concatD [prt 0 str])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print FCat where
+  prt i e = case e of
+   FC n id pathelss pathterms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 n , prt 0 id , doc (showString "[") , prt 0 pathelss , doc (showString "]") , doc (showString "[") , prt 0 pathterms , doc (showString "]") , doc (showString ")")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print PathEl where
+  prt i e = case e of
+   PLabel label -> prPrec i 0 (concatD [prt 0 label])
+   PTerm term -> prPrec i 0 (concatD [prt 0 term])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ".") , prt 0 xs])
+
+instance Print PathTerm where
+  prt i e = case e of
+   PtT pathels term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 pathels , doc (showString ",") , prt 0 term , doc (showString ")")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Name where
+  prt i e = case e of
+   Nm id profiles -> prPrec i 0 (concatD [prt 0 id , doc (showString "[") , prt 0 profiles , doc (showString "]")])
+
+
+instance Print Profile where
+  prt i e = case e of
+   Unify ns -> prPrec i 0 (concatD [doc (showString "[") , prt 0 ns , doc (showString "]")])
+   Const forest -> prPrec i 0 (concatD [prt 0 forest])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Forest where
+  prt i e = case e of
+   FMeta  -> prPrec i 0 (concatD [doc (showString "?")])
+   FNode id forestss -> prPrec i 0 (concatD [doc (showString "(") , prt 0 id , prt 0 forestss , doc (showString ")")])
+   FString str -> prPrec i 0 (concatD [prt 0 str])
+   FInt n -> prPrec i 0 (concatD [prt 0 n])
+   FFloat d -> prPrec i 0 (concatD [prt 0 d])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Term where
+  prt i e = case e of
+   Arg n id pathels -> prPrec i 0 (concatD [doc (showString "(") , prt 0 n , prt 0 id , prt 0 pathels , doc (showString ")")])
+   Constr cident terms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 cident , doc (showString "-") , prt 0 terms , doc (showString ")")])
+   Rec assocs -> prPrec i 0 (concatD [doc (showString "[") , prt 0 assocs , doc (showString "]")])
+   Proj term label -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term , doc (showString ".") , prt 0 label , doc (showString ")")])
+   Tbl cases -> prPrec i 0 (concatD [doc (showString "[-") , prt 0 cases , doc (showString "-]")])
+   Select term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term , doc (showString ")")])
+   Vars terms -> prPrec i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
+   Concat term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "++") , prt 0 term , doc (showString ")")])
+   Tok str -> prPrec i 0 (concatD [prt 0 str])
+   Empty  -> prPrec i 0 (concatD [doc (showString "(") , doc (showString ")")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Case where
+  prt i e = case e of
+   Cas term0 term -> prPrec i 0 (concatD [prt 0 term0 , doc (showString "=>") , prt 0 term])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Assoc where
+  prt i e = case e of
+   Ass label term -> prPrec i 0 (concatD [prt 0 label , doc (showString "=") , prt 0 term])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Label where
+  prt i e = case e of
+   L id -> prPrec i 0 (concatD [prt 0 id])
+   LV n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
+
+
+instance Print CIdent where
+  prt i e = case e of
+   CIQ id0 id -> prPrec i 0 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id])
+
+
+
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)
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index b18dd6357..148cd49fe 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -37,6 +37,7 @@ import qualified GF.Canon.GFC as C
 import qualified GF.Canon.CanonToGFCC as GFCC
 import qualified GF.Source.AbsGF as GF
 import qualified GF.Grammar.MMacros as MM
+import GF.FCFG.ToFCFG
 import GF.Grammar.AbsCompute
 import GF.Grammar.TypeCheck
 import GF.UseGrammar.Generate
@@ -310,6 +311,7 @@ customGrammarPrinter =
 -- grammar conversions:
   ,(strCI "mcfg",     \_ -> Prt.prt . stateMCFG)
   ,(strCI "fcfg",     \_ -> Prt.prt . stateFCFG)
+  ,(strCI "bfcfg",    \_ -> printFGrammar . stateFCFG)
   ,(strCI "mcfg2fcfg",\_ -> Prt.prt . Cnv.mcfg2fcfg . stateMCFG)
   ,(strCI "cfg",      \_ -> Prt.prt . stateCFG)
   ,(strCI "pinfo",    \_ -> Prt.prt . statePInfo)