added parsing of json into canonical GF

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -3,6 +3,8 @@ module GF.Grammar.CanonicalJSON (
   ) where
 
 import Text.JSON
+import Control.Applicative ((<|>))
+import Data.Ratio (denominator, numerator)
 import GF.Grammar.Canonical
 
 
@@ -19,6 +21,8 @@ encodeJSON fpath g = writeFile fpath (encode g)
 instance JSON Grammar where
   showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
 
+  readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
+
 
 --------------------------------------------------------------------------------
 -- ** Abstract Syntax
@@ -30,27 +34,47 @@ instance JSON Abstract where
                ("cats", showJSON cats),
                ("funs", showJSON funs)]
 
+  readJSON o = Abstract
+    <$> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"cats"
+    <*> o!"funs"
+
 instance JSON CatDef where
   -- non-dependent categories are encoded as simple strings:
   showJSON (CatDef c []) = showJSON c
   showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
 
+  readJSON o = CatDef <$> readJSON o <*> return []
+    <|>        CatDef <$> o!"cat" <*> o!"args"
+
 instance JSON FunDef where
   showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
 
+  readJSON o = FunDef <$> o!"fun" <*> o!"type"
+
 instance JSON Type where
   showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
 
+  readJSON o = Type <$> o!".args" <*> o!".result"
+
 instance JSON TypeApp where
   -- non-dependent categories are encoded as simple strings:
   showJSON (TypeApp c [])   = showJSON c
   showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
 
+  readJSON o = TypeApp <$> readJSON o <*> return []
+    <|>        TypeApp <$> o!".cat" <*> o!".args"
+
 instance JSON TypeBinding where
   -- non-dependent categories are encoded as simple strings:
   showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
   showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
 
+  readJSON o = do c <- readJSON o
+                  return (TypeBinding Anonymous (Type [] (TypeApp c [])))
+           <|> TypeBinding <$> o!".var" <*> o!".type"
+
 
 --------------------------------------------------------------------------------
 -- ** Concrete syntax
@@ -64,16 +88,31 @@ instance JSON Concrete where
                ("lincats", showJSON lincats),
                ("lins", showJSON lins)]
 
+  readJSON o = Concrete
+    <$> o!"cnc"
+    <*> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"params"
+    <*> o!"lincats"
+    <*> o!"lins"
+
 instance JSON ParamDef where
   showJSON (ParamDef      p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
   showJSON (ParamAliasDef p t)   = makeObj [("param", showJSON p), ("alias", showJSON t)]
 
+  readJSON o = ParamDef      <$> o!"param" <*> o!"values"
+    <|>        ParamAliasDef <$> o!"param" <*> o!"alias"
+
 instance JSON LincatDef where
   showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
 
+  readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
+
 instance JSON LinDef where
   showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
 
+  readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
+
 instance JSON LinType where
   -- the basic types (Str, Float, Int) are encoded as strings:
   showJSON (StrType)         = showJSON "Str"
@@ -87,6 +126,14 @@ instance JSON LinType where
   -- records are encoded as records:
   showJSON (RecordType rows) = showJSON rows
 
+  readJSON o = do "Str"   <- readJSON o; return StrType
+    <|>        do "Float" <- readJSON o; return FloatType
+    <|>        do "Int"   <- readJSON o; return IntType
+    <|>        do  ptype  <- readJSON o; return (ParamType ptype)
+    <|>        TableType  <$> o!".tblarg" <*> o!".tblval"
+    <|>        TupleType  <$> o!".tuple"
+    <|>        RecordType <$> readJSON o
+
 instance JSON LinValue where
   showJSON (LiteralValue  l ) = showJSON l
   -- concatenation is encoded as a JSON array:
@@ -105,12 +152,27 @@ instance JSON LinValue where
   -- records are encoded directly as JSON records:
   showJSON (RecordValue rows) = showJSON rows
 
+  readJSON o = LiteralValue  <$> readJSON o
+    <|>        ParamConstant <$> o!".param"
+    <|>        PredefValue   <$> o!".predef"
+    <|>        TableValue    <$> o!".tblarg"  <*> o!".tblrows"
+    <|>        TupleValue    <$> o!".tuple"
+    <|>        VarValue      <$> o!".var"
+    <|>        ErrorValue    <$> o!".error"
+    <|>        Projection    <$> o!".project" <*> o!".label"
+    <|>        Selection     <$> o!".select"  <*> o!".key"
+    <|>        VariantValue  <$> o!".variants"
+    <|>        PreValue      <$> o!".pre"     <*> o!".default"
+    <|>        RecordValue   <$> readJSON o
+
 instance JSON LinLiteral where
   -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
   showJSON (StrConstant   s) = showJSON s
   showJSON (FloatConstant f) = showJSON f
   showJSON (IntConstant   n) = showJSON n
 
+  readJSON = readBasicJSON StrConstant IntConstant FloatConstant
+
 instance JSON LinPattern where
   -- wildcards and patterns without arguments are encoded as strings:
   showJSON (WildPattern) = showJSON "_"
@@ -120,53 +182,104 @@ instance JSON LinPattern where
   -- and records as records:
   showJSON (RecordPattern r) = showJSON r
 
+  readJSON o = do "_" <- readJSON o; return WildPattern
+    <|>        do  p  <- readJSON o; return (ParamPattern (Param p []))
+    <|>        ParamPattern  <$> readJSON o
+    <|>        RecordPattern <$> readJSON o
+
 instance JSON arg => JSON (Param arg) where
   -- parameters without arguments are encoded as strings:
   showJSON (Param p [])   = showJSON p
   showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
 
+  readJSON o = Param <$> readJSON o <*> return []
+    <|>        Param <$> o!".paramid" <*> o!".args"
+
 instance JSON a => JSON (RecordRow a) where
   -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
   showJSON  row  = showJSONs [row]
   showJSONs rows = makeObj (map toRow rows)
     where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
 
+  readJSON  obj = head <$> readJSONs obj
+  readJSONs obj = mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (RecordRow (LabelId lbl) value)
 
 instance JSON TableRowValue where
   showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
 
+  readJSON o = TableRowValue <$> o!".pattern" <*> o!".value"
+
 
 -- *** Identifiers in Concrete Syntax
 
-instance JSON PredefId   where showJSON (PredefId    s) = showJSON s
+instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON 
-instance JSON LabelId    where showJSON (LabelId     s) = showJSON s
+instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON 
-instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s
+instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON 
-instance JSON ParamId    where showJSON (ParamId     s) = showJSON s
+instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON 
-instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s
+instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON 
+
 
 --------------------------------------------------------------------------------
 -- ** Used in both Abstract and Concrete Syntax
 
-instance JSON ModId where showJSON (ModId s) = showJSON s
+instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON 
-instance JSON CatId where showJSON (CatId s) = showJSON s
+instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON 
-instance JSON FunId where showJSON (FunId s) = showJSON s
+instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON 
 
 instance JSON VarId where
   -- the anonymous variable is the underscore:
   showJSON Anonymous = showJSON "_"
   showJSON (VarId x) = showJSON x
 
+  readJSON o = do "_" <- readJSON o; return Anonymous
+    <|>        VarId <$> readJSON o
+
 instance JSON QualId where
   showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
   showJSON (Unqual n) = showJSON n
 
+  readJSON o = do qualid <- readJSON o
+                  let (mod, id) = span (/= '.') qualid
+                  return $ if null mod then Unqual id else Qual (ModId mod) id
+
 instance JSON Flags where
   -- flags are encoded directly as JSON records (i.e., objects):
   showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
 
+  readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (lbl, value)
+
 instance JSON FlagValue where
   -- flag values are encoded as basic JSON types:
   showJSON (Str s) = showJSON s
   showJSON (Int i) = showJSON i
   showJSON (Flt f) = showJSON f
 
+  readJSON = readBasicJSON Str Int Flt
+
+
+--------------------------------------------------------------------------------
+-- ** Convenience functions
+
+(!) :: JSON a => JSValue -> String -> Result a
+obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
+            readJSON
+            (lookup key (assocsJSObject obj))
+
+assocsJSObject :: JSValue -> [(String, JSValue)]
+assocsJSObject (JSObject o) = fromJSObject o
+assocsJSObject (JSArray  _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
+assocsJSObject  jsvalue     = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
+
+
+readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
+                 (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
+readBasicJSON str int flt o
+  =   str        <$> readJSON o
+  <|> int_or_flt <$> readJSON o
+  where int_or_flt f | f == fromIntegral n = int n
+                     | otherwise           = flt f
+          where n = round f