From 8cf4446e8cf2cf65aa308c2d69c59a3368194bf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Peter=20Ljunglo=CC=88f?= Date: Fri, 8 Mar 2019 17:21:23 +0100 Subject: [PATCH 1/5] Remove "canonical_yaml" from the option descriptions --- src/compiler/GF/Infra/Option.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index b99e2dbe9..7e1c22b9d 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -327,7 +327,7 @@ optDescr = Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').", Option ['f'] ["output-format"] (ReqArg outFmt "FMT") (unlines ["Output format. FMT can be one of:", - "Canonical GF grammar: canonical_gf, canonical_json, canonical_yaml, (and haskell with option --haskell=concrete)", + "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)", "Multiple concrete: pgf (default), 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, From 3328279120ce771c676b30689283cd7f2493c0f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Peter=20Ljunglo=CC=88f?= Date: Fri, 8 Mar 2019 17:35:01 +0100 Subject: [PATCH 2/5] corrected json printing some object labels must be preceded by ".", to not be in conflict with GF records (which are stored as json objects) plus some minor bugfixes and cleaning --- src/compiler/GF/Grammar/CanonicalJSON.hs | 55 +++++++++++------------- 1 file changed, 25 insertions(+), 30 deletions(-) diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index c14716eea..347af1390 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -3,7 +3,6 @@ module GF.Grammar.CanonicalJSON ( ) where import Text.JSON -import qualified Control.Monad as CM (mapM, msum) import GF.Grammar.Canonical @@ -38,23 +37,19 @@ instance JSON CatDef where instance JSON FunDef where showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)] -{- -instance FromJSON FunDef where - parseJSON = withObject "FunDef" $ \o -> FunDef <$> o .: "fun" <*> o .: "type" --} instance JSON Type where - showJSON (Type bs ty) = makeObj [("args", showJSON bs), ("result", showJSON ty)] + showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)] 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)] + showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON 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)] + showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)] -------------------------------------------------------------------------------- @@ -88,29 +83,29 @@ instance JSON LinType where -- parameters are also encoded as strings: ParamType pt -> showJSON pt -- tables/tuples are encoded as JSON objects: - TableType pt lt -> makeObj [("tblarg", showJSON pt), ("tblval", showJSON lt)] - TupleType lts -> makeObj [("tuple", showJSON lts)] + TableType pt lt -> makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] + TupleType lts -> makeObj [(".tuple", showJSON lts)] -- records are encoded as records: RecordType rows -> showJSON rows instance JSON LinValue where showJSON lv = case lv of - LiteralValue l -> showJSON l + LiteralValue l -> showJSON l -- concatenation is encoded as a JSON array: - ConcatValue v v' -> showJSON [showJSON v, showJSON v'] + ConcatValue v v' -> showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: - ParamConstant pv -> makeObj [("param", showJSON pv)] - PredefValue p -> makeObj [("predef", showJSON p)] - TableValue t tvs -> makeObj [("tblarg", showJSON t), ("tblrows", showJSON tvs)] - TupleValue lvs -> makeObj [("tuple", showJSON lvs)] - VarValue v -> makeObj [("var", showJSON v)] - ErrorValue s -> makeObj [("error", showJSON s)] - Projection lv l -> makeObj [("project", showJSON lv), ("label", showJSON l)] - Selection tv pv -> makeObj [("select", showJSON tv), ("key", showJSON pv)] - VariantValue vs -> makeObj [("variants", showJSON vs)] - PreValue alts def -> makeObj [("pre", showJSON alts), ("default", showJSON def)] + ParamConstant pv -> makeObj [(".param", showJSON pv)] + PredefValue p -> makeObj [(".predef", showJSON p)] + TableValue t tvs -> makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] + TupleValue lvs -> makeObj [(".tuple", showJSON lvs)] + VarValue v -> makeObj [(".var", showJSON v)] + ErrorValue s -> makeObj [(".error", showJSON s)] + Projection lv l -> makeObj [(".project", showJSON lv), (".label", showJSON l)] + Selection tv pv -> makeObj [(".select", showJSON tv), (".key", showJSON pv)] + VariantValue vs -> makeObj [(".variants", showJSON vs)] + PreValue pre def -> makeObj [(".pre", showJSON pre),(".default", showJSON def)] -- records are encoded directly as JSON records: - RecordValue rows -> showJSON rows + RecordValue rows -> showJSON rows instance JSON LinLiteral where showJSON l = case l of @@ -132,17 +127,17 @@ instance JSON LinPattern where 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)] + showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON 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 = makeObj [toJSONRecordRow row] + showJSON row = showJSONs [row] + showJSONs rows = makeObj (map toRow rows) + where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) -toJSONRecordRow :: JSON a => RecordRow a -> (String,JSValue) -toJSONRecordRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val) instance JSON TableRowValue where - showJSON (TableRowValue l v) = makeObj [("pattern", showJSON l), ("value", showJSON l)] + showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)] -- *** Identifiers in Concrete Syntax @@ -166,12 +161,12 @@ instance JSON VarId where showJSON (VarId x) = showJSON x instance JSON QualId where - showJSON (Qual (ModId m) n) = showJSON (m++"_"++n) + showJSON (Qual (ModId m) n) = showJSON (m++"."++n) showJSON (Unqual n) = showJSON n instance JSON Flags where -- flags are encoded directly as JSON records (i.e., objects): - showJSON (Flags fs) = makeObj [(f,showJSON v) | (f, v) <- fs] + showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs] instance JSON FlagValue where -- flag values are encoded as basic JSON types: From 21140fc0c0dce1e7730a3d679815e48db0ab3804 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Peter=20Ljunglo=CC=88f?= Date: Fri, 8 Mar 2019 17:57:02 +0100 Subject: [PATCH 3/5] remove case expressions (no particular reason) --- src/compiler/GF/Grammar/CanonicalJSON.hs | 80 +++++++++++------------- 1 file changed, 38 insertions(+), 42 deletions(-) diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 347af1390..3be47a1a8 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -75,54 +75,50 @@ instance JSON LinDef where showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)] instance JSON LinType where - showJSON lt = case lt of - -- the basic types (Str, Float, Int) are encoded as strings: - StrType -> showJSON "Str" - FloatType -> showJSON "Float" - IntType -> showJSON "Int" - -- parameters are also encoded as strings: - ParamType pt -> showJSON pt - -- tables/tuples are encoded as JSON objects: - TableType pt lt -> makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] - TupleType lts -> makeObj [(".tuple", showJSON lts)] - -- records are encoded as records: - RecordType rows -> showJSON rows + -- the basic types (Str, Float, Int) are encoded as strings: + showJSON (StrType) = showJSON "Str" + showJSON (FloatType) = showJSON "Float" + showJSON (IntType) = showJSON "Int" + -- parameters are also encoded as strings: + showJSON (ParamType pt) = showJSON pt + -- tables/tuples are encoded as JSON objects: + showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)] + showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)] + -- records are encoded as records: + showJSON (RecordType rows) = showJSON rows instance JSON LinValue where - showJSON lv = case lv of - LiteralValue l -> showJSON l - -- concatenation is encoded as a JSON array: - ConcatValue v v' -> showJSON [showJSON v, showJSON v'] - -- most values are encoded as JSON objects: - ParamConstant pv -> makeObj [(".param", showJSON pv)] - PredefValue p -> makeObj [(".predef", showJSON p)] - TableValue t tvs -> makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] - TupleValue lvs -> makeObj [(".tuple", showJSON lvs)] - VarValue v -> makeObj [(".var", showJSON v)] - ErrorValue s -> makeObj [(".error", showJSON s)] - Projection lv l -> makeObj [(".project", showJSON lv), (".label", showJSON l)] - Selection tv pv -> makeObj [(".select", showJSON tv), (".key", showJSON pv)] - VariantValue vs -> makeObj [(".variants", showJSON vs)] - PreValue pre def -> makeObj [(".pre", showJSON pre),(".default", showJSON def)] - -- records are encoded directly as JSON records: - RecordValue rows -> showJSON rows + showJSON (LiteralValue l ) = showJSON l + -- concatenation is encoded as a JSON array: + showJSON (ConcatValue v v') = showJSON [showJSON v, showJSON v'] + -- most values are encoded as JSON objects: + showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)] + showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)] + showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)] + showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)] + showJSON (VarValue v ) = makeObj [(".var", showJSON v)] + showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)] + showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)] + showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)] + showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)] + showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)] + -- records are encoded directly as JSON records: + showJSON (RecordValue rows) = showJSON rows instance JSON LinLiteral where - showJSON l = case l of - -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: - StrConstant s -> showJSON s - FloatConstant f -> showJSON f - IntConstant n -> showJSON n + -- 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 instance JSON LinPattern where - showJSON linpat = case linpat of - -- wildcards and patterns without arguments are encoded as strings: - WildPattern -> showJSON "_" - ParamPattern (Param p []) -> showJSON p - -- complex patterns are encoded as JSON objects: - ParamPattern pv -> showJSON pv - -- and records as records: - RecordPattern r -> showJSON r + -- wildcards and patterns without arguments are encoded as strings: + showJSON (WildPattern) = showJSON "_" + showJSON (ParamPattern (Param p [])) = showJSON p + -- complex patterns are encoded as JSON objects: + showJSON (ParamPattern pv) = showJSON pv + -- and records as records: + showJSON (RecordPattern r) = showJSON r instance JSON arg => JSON (Param arg) where -- parameters without arguments are encoded as strings: From 926a5cf41475e7aec0b40920d2bc30444afda39c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Peter=20Ljunglo=CC=88f?= Date: Fri, 8 Mar 2019 17:58:24 +0100 Subject: [PATCH 4/5] added parsing of json into canonical GF --- src/compiler/GF/Grammar/CanonicalJSON.hs | 129 +++++++++++++++++++++-- 1 file changed, 121 insertions(+), 8 deletions(-) diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index 3be47a1a8..ae2c5fab5 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/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 LabelId where showJSON (LabelId s) = showJSON s -instance JSON VarValueId where showJSON (VarValueId s) = showJSON s -instance JSON ParamId where showJSON (ParamId s) = showJSON s -instance JSON ParamType where showJSON (ParamTypeId 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 ; readJSON = fmap LabelId . readJSON +instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON +instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON +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 CatId where showJSON (CatId s) = showJSON s -instance JSON FunId where showJSON (FunId 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 ; readJSON = fmap CatId . readJSON +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 From 01b9e8da8da56279122395219440760972b4fe49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Peter=20Ljunglo=CC=88f?= Date: Fri, 8 Mar 2019 18:33:56 +0100 Subject: [PATCH 5/5] canonical GF: flatten several concatenations into one json array, and parse the array back into concatenations --- src/compiler/GF/Grammar/CanonicalJSON.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index ae2c5fab5..8024fe99a 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -136,8 +136,6 @@ instance JSON LinType where instance JSON LinValue where showJSON (LiteralValue l ) = showJSON l - -- concatenation is encoded as a JSON array: - showJSON (ConcatValue v v') = showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)] showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)] @@ -151,6 +149,10 @@ instance JSON LinValue where showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)] -- records are encoded directly as JSON records: showJSON (RecordValue rows) = showJSON rows + -- concatenation is encoded as a JSON array: + showJSON v@(ConcatValue _ _) = showJSON (flatten v []) + where flatten (ConcatValue v v') = flatten v . flatten v' + flatten v = (v :) readJSON o = LiteralValue <$> readJSON o <|> ParamConstant <$> o!".param" @@ -164,6 +166,8 @@ instance JSON LinValue where <|> VariantValue <$> o!".variants" <|> PreValue <$> o!".pre" <*> o!".default" <|> RecordValue <$> readJSON o + <|> do vs <- readJSON o :: Result [LinValue] + return (foldr1 ConcatValue vs) instance JSON LinLiteral where -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: