From c5a75c482ccaf1ce955694fb63dd4e05e9d34a02 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 3 Jul 2019 15:07:31 +0200 Subject: Start work on PGFtoJSON module. Add compiler flag `-f json`. --- src/compiler/GF/Compile/Export.hs | 2 + src/compiler/GF/Compile/PGFtoJSON.hs | 116 +++++++++++++++++++++++++++++++++++ src/compiler/GF/Infra/Option.hs | 4 +- 3 files changed, 121 insertions(+), 1 deletion(-) create mode 100644 src/compiler/GF/Compile/PGFtoJSON.hs (limited to 'src') 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)"), -- cgit v1.2.3 From ecf9b41db0a058a0477a6f19fba1ba30ca6643c3 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 3 Jul 2019 16:34:07 +0200 Subject: Finish JSON conversion for abstract --- src/compiler/GF/Compile/PGFtoJSON.hs | 45 +++++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs index ec336835a..6563ea6c8 100644 --- a/src/compiler/GF/Compile/PGFtoJSON.hs +++ b/src/compiler/GF/Compile/PGFtoJSON.hs @@ -4,6 +4,10 @@ import PGF(showCId) import PGF.Internal as M import qualified Text.JSON as JSON +import Text.JSON (JSValue(..)) +-- import Text.JSON.Pretty (pp_value) +-- import Text.PrettyPrint (render) + --import GF.Data.ErrM --import GF.Infra.Option @@ -19,38 +23,47 @@ import qualified Data.IntMap as IntMap pgf2json :: PGF -> String pgf2json pgf = JSON.encode $ JSON.makeObj + -- render $ pp_value $ 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 + 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_abstract = abstract2json n start as json_concretes = JSON.makeObj $ map concrete2json cs -abstract2json :: String -> Abstr -> JSON.JSValue -abstract2json start ds = JSON.JSNull +abstract2json :: String -> String -> Abstr -> JSValue +abstract2json name start ds = + JSON.makeObj + [ ("name", JSString $ JSON.toJSString name) + , ("startcat", JSString $ JSON.toJSString start) + , ("funs", JSON.makeObj $ map absdef2js (Map.assocs (funs ds))) + ] -- 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)]) --- + +absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue) +absdef2js (f,(typ,_,_,_)) = (showCId f,sig) + where + (args,cat) = M.catSkeleton typ + sig = JSON.makeObj + [ ("args", JSArray $ map (mkJSString.showCId) args) + , ("cat", mkJSString $ showCId cat) + ] + +mkJSString :: String -> JSValue +mkJSString = JSString . JSON.toJSString + -- 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) +concrete2json :: (CId,Concr) -> (String,JSValue) +concrete2json (c,cnc) = (showCId c,JSNull) -- concrete2js :: (CId,Concr) -> JS.Property -- concrete2js (c,cnc) = -- cgit v1.2.3 From cb88b56016f8517ab6d370c3862924f3db806e95 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Sun, 7 Jul 2019 17:35:31 +0200 Subject: Finish compile to PGF JSON, including JSON schema for resulting format. --- src/compiler/GF/Compile/PGFtoJSON.hs | 180 +++++++++++++------------ src/compiler/GF/Compile/pgf.schema.json | 232 ++++++++++++++++++++++++++++++++ 2 files changed, 325 insertions(+), 87 deletions(-) create mode 100644 src/compiler/GF/Compile/pgf.schema.json (limited to 'src') diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs index 6563ea6c8..7b585fc89 100644 --- a/src/compiler/GF/Compile/PGFtoJSON.hs +++ b/src/compiler/GF/Compile/PGFtoJSON.hs @@ -4,17 +4,11 @@ import PGF(showCId) import PGF.Internal as M import qualified Text.JSON as JSON -import Text.JSON (JSValue(..)) +import Text.JSON (JSValue(..), JSON) -- import Text.JSON.Pretty (pp_value) -- import Text.PrettyPrint (render) ---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 @@ -38,92 +32,104 @@ pgf2json pgf = abstract2json :: String -> String -> Abstr -> JSValue abstract2json name start ds = JSON.makeObj - [ ("name", JSString $ JSON.toJSString name) - , ("startcat", JSString $ JSON.toJSString start) - , ("funs", JSON.makeObj $ map absdef2js (Map.assocs (funs ds))) + [ ("name", mkJSStr name) + , ("startcat", mkJSStr start) + , ("funs", JSON.makeObj $ map absdef2json (Map.assocs (funs ds))) ] --- 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)) -> (String,JSValue) -absdef2js (f,(typ,_,_,_)) = (showCId f,sig) +absdef2json :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> (String,JSValue) +absdef2json (f,(typ,_,_,_)) = (showCId f,sig) where (args,cat) = M.catSkeleton typ sig = JSON.makeObj - [ ("args", JSArray $ map (mkJSString.showCId) args) - , ("cat", mkJSString $ showCId cat) + [ ("args", JSArray $ map (mkJSStr.showCId) args) + , ("cat", mkJSStr $ showCId cat) ] -mkJSString :: String -> JSValue -mkJSString = JSString . JSON.toJSString - --- lit2js (LStr s) = JS.EStr s --- lit2js (LInt n) = JS.EInt n --- lit2js (LFlt d) = JS.EDbl d +lit2json :: Literal -> JSValue +lit2json (LStr s) = mkJSStr s +lit2json (LInt n) = mkJSInt n +lit2json (LFlt d) = JSRational True (toRational d) concrete2json :: (CId,Concr) -> (String,JSValue) -concrete2json (c,cnc) = (showCId c,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 ] +concrete2json (c,cnc) = (showCId c,obj) + where + obj = JSON.makeObj + [ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ]) + , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)]) -- TODO + , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc)))) + , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc)))) + , ("startCats", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc))) + , ("totalFIds", mkJSInt (totalCats cnc)) + ] + +cats2json :: (CId, CncCat) -> (String,JSValue) +cats2json (c,CncCat start end _) = (showCId c, ixs) + where + ixs = JSON.encJSDict + [ ("s", start) + , ("e", end) + ] + +frule2json :: Production -> JSValue +frule2json (PApply fid args) = + JSON.makeObj + [ ("type", mkJSStr "Apply") + , ("fid", mkJSInt fid) + , ("args", JSArray (map farg2json args)) + ] +frule2json (PCoerce arg) = + JSON.makeObj + [ ("type", mkJSStr "Coerce") + , ("arg", mkJSInt arg) + ] + +farg2json :: PArg -> JSValue +farg2json (PArg hypos fid) = + JSON.makeObj + [ ("type", mkJSStr "PArg") + , ("hypos", JSArray $ map (mkJSInt . snd) hypos) + , ("fid", mkJSInt fid) + ] + +ffun2json :: CncFun -> JSValue +ffun2json (CncFun f lins) = + JSON.makeObj + [ ("name", mkJSStr $ showCId f) + , ("lins", JSArray (map mkJSInt (Array.elems lins))) + ] + +seq2json :: Array.Array DotPos Symbol -> JSValue +seq2json seq = JSArray [sym2json s | s <- Array.elems seq] + +sym2json :: Symbol -> JSValue +sym2json (SymCat n l) = new "SymCat" [mkJSInt n, mkJSInt l] +sym2json (SymLit n l) = new "SymLit" [mkJSInt n, mkJSInt l] +sym2json (SymVar n l) = new "SymVar" [mkJSInt n, mkJSInt l] +sym2json (SymKS t) = new "SymKS" [mkJSStr t] +sym2json (SymKP ts alts) = new "SymKP" [JSArray (map sym2json ts), JSArray (map alt2json alts)] +sym2json SymBIND = new "SymKS" [mkJSStr "&+"] +sym2json SymSOFT_BIND = new "SymKS" [mkJSStr "&+"] +sym2json SymSOFT_SPACE = new "SymKS" [mkJSStr "&+"] +sym2json SymCAPIT = new "SymKS" [mkJSStr "&|"] +sym2json SymALL_CAPIT = new "SymKS" [mkJSStr "&|"] +sym2json SymNE = new "SymNE" [] + +alt2json :: ([Symbol],[String]) -> JSValue +alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)] + +new :: String -> [JSValue] -> JSValue +new f xs = + JSON.makeObj + [ ("type", mkJSStr f) + , ("args", JSArray xs) + ] + +-- | Make JSON value from string +mkJSStr :: String -> JSValue +mkJSStr = JSString . JSON.toJSString + +-- | Make JSON value from integer +mkJSInt :: Integral a => a -> JSValue +mkJSInt = JSRational False . toRational + diff --git a/src/compiler/GF/Compile/pgf.schema.json b/src/compiler/GF/Compile/pgf.schema.json new file mode 100644 index 000000000..2ad1d5442 --- /dev/null +++ b/src/compiler/GF/Compile/pgf.schema.json @@ -0,0 +1,232 @@ +{ + "$schema": "http://json-schema.org/draft-07/schema#", + "$id": "http://grammaticalframework.org/pgf.schema.json", + "type": "object", + "title": "PGF JSON Schema", + "required": [ + "abstract", + "concretes" + ], + "properties": { + "abstract": { + "type": "object", + "required": [ + "name", + "startcat", + "funs" + ], + "properties": { + "name": { + "type": "string" + }, + "startcat": { + "type": "string" + }, + "funs": { + "type": "object", + "additionalProperties": { + "type": "object", + "required": [ + "args", + "cat" + ], + "properties": { + "args": { + "type": "array", + "items": { + "type": "string" + } + }, + "cat": { + "type": "string" + } + } + } + } + } + }, + "concretes": { + "type": "object", + "additionalProperties": { + "required": [ + "flags", + "productions", + "functions", + "sequences", + "startCats", + "totalFIds" + ], + "properties": { + "flags": { + "type": "object", + "additionalProperties": { + "type": ["string", "number"] + } + }, + "productions": { + "type": "object", + "additionalProperties": { + "type": "array", + "items": { + "oneOf": [ + { + "$ref": "#/definitions/apply" + }, + { + "$ref": "#/definitions/coerce" + } + ] + } + } + }, + "functions": { + "type": "array", + "items": { + "title": "CncFun", + "type": "object", + "properties": { + "name": { + "type": "string" + }, + "lins": { + "type": "array", + "items": { + "type": "integer" + } + } + } + } + }, + "sequences": { + "type": "array", + "items": { + "type": "array", + "items": { + "$ref": "#/definitions/sym" + } + } + }, + "startCats": { + "type": "object", + "additionalProperties": { + "title": "CncCat", + "type": "object", + "required": [ + "s", + "e" + ], + "properties": { + "s": { + "type": "integer" + }, + "e": { + "type": "integer" + } + } + } + }, + "totalFIds": { + "type": "integer" + } + } + } + } + }, + "definitions": { + "apply": { + "required": [ + "type", + "fid", + "args" + ], + "properties": { + "type": { + "type": "string", + "enum": ["Apply"] + }, + "fid": { + "type": "integer" + }, + "args": { + "type": "array", + "items": { + "$ref": "#/definitions/parg" + } + } + } + }, + "coerce": { + "required": [ + "type", + "arg" + ], + "properties": { + "type": { + "type": "string", + "enum": ["Coerce"] + }, + "arg": { + "type": "integer" + } + } + }, + "parg": { + "required": [ + "type", + "hypos", + "fid" + ], + "properties": { + "type": { + "type": "string", + "enum": ["PArg"] + }, + "hypos": { + "type": "array", + "items": { + "type": "integer" + } + }, + "fid": { + "type": "integer" + } + } + }, + "sym": { + "title": "Sym", + "required": [ + "type", + "args" + ], + "properties": { + "type": { + "type": "string", + "enum": [ + "SymCat", + "SymLit", + "SymVar", + "SymKS", + "SymKP", + "SymNE" + ] + }, + "args": { + "type": "array", + "items": { + "anyOf": [ + { + "type": "string" + }, + { + "type": "integer" + }, + { + "$ref": "#/definitions/sym" + } + ] + } + } + } + } + } +} \ No newline at end of file -- cgit v1.2.3 From a4b1fb03aa88bd501dc7fd2c7c7bd4dae7c4cf72 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Sun, 7 Jul 2019 17:38:07 +0200 Subject: Whitespace fixes --- src/compiler/GF/Compile/PGFtoJSON.hs | 5 ++--- src/compiler/GF/Compile/pgf.schema.json | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs index 7b585fc89..9a86d3e59 100644 --- a/src/compiler/GF/Compile/PGFtoJSON.hs +++ b/src/compiler/GF/Compile/PGFtoJSON.hs @@ -97,7 +97,7 @@ ffun2json (CncFun f lins) = JSON.makeObj [ ("name", mkJSStr $ showCId f) , ("lins", JSArray (map mkJSInt (Array.elems lins))) - ] + ] seq2json :: Array.Array DotPos Symbol -> JSValue seq2json seq = JSArray [sym2json s | s <- Array.elems seq] @@ -119,7 +119,7 @@ alt2json :: ([Symbol],[String]) -> JSValue alt2json (ps,ts) = new "Alt" [JSArray (map sym2json ps), JSArray (map mkJSStr ts)] new :: String -> [JSValue] -> JSValue -new f xs = +new f xs = JSON.makeObj [ ("type", mkJSStr f) , ("args", JSArray xs) @@ -132,4 +132,3 @@ mkJSStr = JSString . JSON.toJSString -- | Make JSON value from integer mkJSInt :: Integral a => a -> JSValue mkJSInt = JSRational False . toRational - diff --git a/src/compiler/GF/Compile/pgf.schema.json b/src/compiler/GF/Compile/pgf.schema.json index 2ad1d5442..a8f31e399 100644 --- a/src/compiler/GF/Compile/pgf.schema.json +++ b/src/compiler/GF/Compile/pgf.schema.json @@ -229,4 +229,4 @@ } } } -} \ No newline at end of file +} -- cgit v1.2.3 From acd4a5e8cd3e75b9aaa07b36442406b392520ede Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 10 Jul 2019 08:45:23 +0200 Subject: Address @heatherleaf's suggestions --- src/compiler/GF/Compile/PGFtoJSON.hs | 42 +++++++++++++++++++++++++++--------- 1 file changed, 32 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs index 9a86d3e59..3fd3b60cb 100644 --- a/src/compiler/GF/Compile/PGFtoJSON.hs +++ b/src/compiler/GF/Compile/PGFtoJSON.hs @@ -1,12 +1,35 @@ module GF.Compile.PGFtoJSON (pgf2json) where -import PGF(showCId) -import PGF.Internal as M +import PGF (showCId) +import qualified PGF.Internal as M +import PGF.Internal ( + Abstr, + CId, + CncCat(..), + CncFun(..), + Concr, + DotPos, + Equation(..), + Literal(..), + PArg(..), + PGF, + Production(..), + Symbol(..), + Type, + absname, + abstract, + cflags, + cnccats, + cncfuns, + concretes, + funs, + productions, + sequences, + totalCats + ) import qualified Text.JSON as JSON -import Text.JSON (JSValue(..), JSON) --- import Text.JSON.Pretty (pp_value) --- import Text.PrettyPrint (render) +import Text.JSON (JSValue(..)) import qualified Data.Array.IArray as Array import Data.Map (Map) @@ -17,7 +40,6 @@ import qualified Data.IntMap as IntMap pgf2json :: PGF -> String pgf2json pgf = JSON.encode $ JSON.makeObj - -- render $ pp_value $ JSON.makeObj [ ("abstract", json_abstract) , ("concretes", json_concretes) ] @@ -56,7 +78,7 @@ concrete2json (c,cnc) = (showCId c,obj) where obj = JSON.makeObj [ ("flags", JSON.makeObj [ (showCId k, lit2json v) | (k,v) <- Map.toList (cflags cnc) ]) - , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)]) -- TODO + , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)]) , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc)))) , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc)))) , ("startCats", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc))) @@ -66,9 +88,9 @@ concrete2json (c,cnc) = (showCId c,obj) cats2json :: (CId, CncCat) -> (String,JSValue) cats2json (c,CncCat start end _) = (showCId c, ixs) where - ixs = JSON.encJSDict - [ ("s", start) - , ("e", end) + ixs = JSON.makeObj + [ ("s", mkJSInt start) + , ("e", mkJSInt end) ] frule2json :: Production -> JSValue -- cgit v1.2.3 From eab9fb88aaa5408c342927693d8593f1e0ba2b91 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 10 Jul 2019 08:49:00 +0200 Subject: Minor renamings in JSON format --- src/compiler/GF/Compile/PGFtoJSON.hs | 8 ++++---- src/compiler/GF/Compile/pgf.schema.json | 16 ++++++++-------- 2 files changed, 12 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/compiler/GF/Compile/PGFtoJSON.hs b/src/compiler/GF/Compile/PGFtoJSON.hs index 3fd3b60cb..e634dae67 100644 --- a/src/compiler/GF/Compile/PGFtoJSON.hs +++ b/src/compiler/GF/Compile/PGFtoJSON.hs @@ -81,16 +81,16 @@ concrete2json (c,cnc) = (showCId c,obj) , ("productions", JSON.makeObj [ (show cat, JSArray (map frule2json (Set.toList set))) | (cat,set) <- IntMap.toList (productions cnc)]) , ("functions", JSArray (map ffun2json (Array.elems (cncfuns cnc)))) , ("sequences", JSArray (map seq2json (Array.elems (sequences cnc)))) - , ("startCats", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc))) - , ("totalFIds", mkJSInt (totalCats cnc)) + , ("categories", JSON.makeObj $ map cats2json (Map.assocs (cnccats cnc))) + , ("totalfids", mkJSInt (totalCats cnc)) ] cats2json :: (CId, CncCat) -> (String,JSValue) cats2json (c,CncCat start end _) = (showCId c, ixs) where ixs = JSON.makeObj - [ ("s", mkJSInt start) - , ("e", mkJSInt end) + [ ("start", mkJSInt start) + , ("end", mkJSInt end) ] frule2json :: Production -> JSValue diff --git a/src/compiler/GF/Compile/pgf.schema.json b/src/compiler/GF/Compile/pgf.schema.json index a8f31e399..2058e9a70 100644 --- a/src/compiler/GF/Compile/pgf.schema.json +++ b/src/compiler/GF/Compile/pgf.schema.json @@ -53,8 +53,8 @@ "productions", "functions", "sequences", - "startCats", - "totalFIds" + "categories", + "totalfids" ], "properties": { "flags": { @@ -106,26 +106,26 @@ } } }, - "startCats": { + "categories": { "type": "object", "additionalProperties": { "title": "CncCat", "type": "object", "required": [ - "s", - "e" + "start", + "end" ], "properties": { - "s": { + "start": { "type": "integer" }, - "e": { + "end": { "type": "integer" } } } }, - "totalFIds": { + "totalfids": { "type": "integer" } } -- cgit v1.2.3