Finish compile to PGF JSON, including JSON schema for resulting format.

2 files changed, 325 insertions, 87 deletions

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