diff --git a/gf.cabal b/gf.cabal index e7a5e100d..156f6518d 100644 --- a/gf.cabal +++ b/gf.cabal @@ -194,6 +194,7 @@ Library GF.Compile.GrammarToCanonical GF.Grammar.CanonicalJSON GF.Compile.PGFtoJS + GF.Compile.PGFtoJSON GF.Compile.PGFtoProlog GF.Compile.PGFtoPython GF.Compile.ReadFiles diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index e0811d40d..7d3337e3d 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -7,6 +7,7 @@ import GF.Compile.PGFtoHaskell import GF.Compile.PGFtoJava import GF.Compile.PGFtoProlog import GF.Compile.PGFtoJS +import GF.Compile.PGFtoJSON import GF.Compile.PGFtoPython import GF.Infra.Option --import GF.Speech.CFG @@ -38,6 +39,7 @@ exportPGF opts fmt pgf = FmtCanonicalGF -> [] -- canon "gf" (render80 . abstract2canonical) FmtCanonicalJson-> [] FmtJavaScript -> multi "js" pgf2js + FmtJSON -> multi "json" pgf2json FmtPython -> multi "py" pgf2python FmtHaskell -> multi "hs" (grammar2haskell opts name) FmtJava -> multi "java" (grammar2java opts name) diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs new file mode 100644 index 000000000..ec336835a --- /dev/null +++ b/src/compiler/GF/Compile/PGFtoJSON.hs @@ -0,0 +1,116 @@ +module GF.Compile.PGFtoJSON (pgf2json) where + +import PGF(showCId) +import PGF.Internal as M + +import qualified Text.JSON as JSON +--import GF.Data.ErrM +--import GF.Infra.Option + +--import Control.Monad (mplus) +--import Data.Array.Unboxed (UArray) +import qualified Data.Array.IArray as Array +--import Data.Maybe (fromMaybe) +import Data.Map (Map) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +pgf2json :: PGF -> String +pgf2json pgf = + JSON.encode $ JSON.makeObj + [ ("abstract", json_abstract) + , ("concretes", json_concretes) + ] + -- JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] + where + -- n = showCId $ absname pgf + as = abstract pgf + cs = Map.assocs (concretes pgf) + start = showCId $ M.lookStartCat pgf + -- grammar = new "GFGrammar" [js_abstract, js_concrete] + -- js_abstract = abstract2js start as + -- js_concrete = JS.EObj $ map concrete2js cs + json_abstract = abstract2json start as + json_concretes = JSON.makeObj $ map concrete2json cs + +abstract2json :: String -> Abstr -> JSON.JSValue +abstract2json start ds = JSON.JSNull + +-- abstract2js :: String -> Abstr -> JS.Expr +-- abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] +-- +-- absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property +-- absdef2js (f,(typ,_,_,_)) = +-- let (args,cat) = M.catSkeleton typ in +-- JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)]) +-- +-- lit2js (LStr s) = JS.EStr s +-- lit2js (LInt n) = JS.EInt n +-- lit2js (LFlt d) = JS.EDbl d + +concrete2json :: (CId,Concr) -> (String,JSON.JSValue) +concrete2json (c,cnc) = (showCId c,JSON.JSNull) + +-- concrete2js :: (CId,Concr) -> JS.Property +-- concrete2js (c,cnc) = +-- JS.Prop l (new "GFConcrete" [mapToJSObj (lit2js) $ cflags cnc, +-- JS.EObj $ [JS.Prop (JS.IntPropName cat) (JS.EArray (map frule2js (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)], +-- JS.EArray $ (map ffun2js (Array.elems (cncfuns cnc))), +-- JS.EArray $ (map seq2js (Array.elems (sequences cnc))), +-- JS.EObj $ map cats (Map.assocs (cnccats cnc)), +-- JS.EInt (totalCats cnc)]) +-- where +-- l = JS.IdentPropName (JS.Ident (showCId c)) +-- {- +-- litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), +-- JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), +-- JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])] +-- -} +-- cats (c,CncCat start end _) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EObj [JS.Prop (JS.IdentPropName (JS.Ident "s")) (JS.EInt start) +-- ,JS.Prop (JS.IdentPropName (JS.Ident "e")) (JS.EInt end)]) +-- {- +-- mkStr :: String -> JS.Expr +-- mkStr s = new "Str" [JS.EStr s] +-- +-- mkSeq :: [JS.Expr] -> JS.Expr +-- mkSeq [x] = x +-- mkSeq xs = new "Seq" xs +-- +-- argIdent :: Integer -> JS.Ident +-- argIdent n = JS.Ident ("x" ++ show n) +-- -} +-- children :: JS.Ident +-- children = JS.Ident "cs" +-- +-- frule2js :: Production -> JS.Expr +-- frule2js (PApply funid args) = new "Apply" [JS.EInt funid, JS.EArray (map farg2js args)] +-- frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg] +-- +-- farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid]) +-- +-- ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))] +-- +-- seq2js :: Array.Array DotPos Symbol -> JS.Expr +-- seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq] +-- +-- sym2js :: Symbol -> JS.Expr +-- sym2js (SymCat n l) = new "SymCat" [JS.EInt n, JS.EInt l] +-- sym2js (SymLit n l) = new "SymLit" [JS.EInt n, JS.EInt l] +-- sym2js (SymVar n l) = new "SymVar" [JS.EInt n, JS.EInt l] +-- sym2js (SymKS t) = new "SymKS" [JS.EStr t] +-- sym2js (SymKP ts alts) = new "SymKP" [JS.EArray (map sym2js ts), JS.EArray (map alt2js alts)] +-- sym2js SymBIND = new "SymKS" [JS.EStr "&+"] +-- sym2js SymSOFT_BIND = new "SymKS" [JS.EStr "&+"] +-- sym2js SymSOFT_SPACE = new "SymKS" [JS.EStr "&+"] +-- sym2js SymCAPIT = new "SymKS" [JS.EStr "&|"] +-- sym2js SymALL_CAPIT = new "SymKS" [JS.EStr "&|"] +-- sym2js SymNE = new "SymNE" [] +-- +-- alt2js (ps,ts) = new "Alt" [JS.EArray (map sym2js ps), JS.EArray (map JS.EStr ts)] +-- +-- new :: String -> [JS.Expr] -> JS.Expr +-- new f xs = JS.ENew (JS.Ident f) xs +-- +-- mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr +-- mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ] diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 7e1c22b9d..7455c83c4 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -90,6 +90,7 @@ data OutputFormat = FmtPGFPretty | FmtCanonicalGF | FmtCanonicalJson | FmtJavaScript + | FmtJSON | FmtPython | FmtHaskell | FmtJava @@ -328,7 +329,7 @@ optDescr = Option ['f'] ["output-format"] (ReqArg outFmt "FMT") (unlines ["Output format. FMT can be one of:", "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)", - "Multiple concrete: pgf (default), js, pgf_pretty, prolog, python, ...", -- gar, + "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar, "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf, "Abstract only: haskell, ..."]), -- prolog_abs, Option [] ["sisr"] (ReqArg sisrFmt "FMT") @@ -474,6 +475,7 @@ outputFormatsExpl = (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"), (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"), (("js", FmtJavaScript),"JavaScript (whole grammar)"), + (("json", FmtJSON),"JSON (whole grammar)"), (("python", FmtPython),"Python (whole grammar)"), (("haskell", FmtHaskell),"Haskell (abstract syntax)"), (("java", FmtJava),"Java (abstract syntax)"),